Supportnet Computer
Planet of Tech

Supportnet / Forum / Tabellenkalkulation

Makro Code verbessern





Frage

Hallo Excelspezialisten, ich habe ein Makro, das aus einer Tabelle (MW) nach einem Autofilter Werte kopiert und in eine andere (Auswerten) überträgt. Da der Kopiervorgang zweimal (verschiedene Zeilen) durchgeführt wird, werden immer wieder die Ansichten (Sheets("MW").Select) gewechselt. Kann man verhindern, das die Tabelle (Auswerten) auch immer wieder kurz angezeigt wird? Ich hoffe ihr habt dazu eine Lösung! Gruß fedjo Sub Mittelwert() Sheets("MW").Range("B5:B65536").Cells.SpecialCells(xlCellTypeVisible)(1).Copy ´findet die fünfte Zelle in B Sheets("Auswerten").Select Range("A65536").End(xlUp).Select Cells(ActiveCell.Row + 1, ActiveCell.Column).Activate ActiveSheet.Paste Sheets("MW").Range("E2:J2").Copy Sheets("Auswerten").Select Range("B65536").End(xlUp).Select Cells(ActiveCell.Row + 1, ActiveCell.Column).Activate Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False Range("A2:G500").Select Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _ OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom Range("A1").Select Sheets("MW").Select End Sub

Antwort 1 von Beverly

Hi Fedjo,

ich habe mir jetzt nicht deinen Code angeschaut, da ich den Aufbau deiner Arbeitsmappe nicht kenne, sondern bin einfach mal nach der Beschreibung deiner Aufgabenstellung gegangen

Sub kopieren()
    Dim loZeile As Long     ´ Zeilenzähler für Schleife
    Dim loLetzte As Long    ´ letzte belegte Zelle
    Application.ScreenUpdating = False
    With Worksheets("Tabelle1")
´       letzte belegte Zelle in Spalte B als Endwert für die Schleife
        loLetzte = IIf(IsEmpty(.Cells(Rows.Count, 2)), .Cells(Rows.Count, 2).End(xlUp).Row, .Rows.Count)
        For loZeile = 1 To loLetzte
´           nur die sichtbaren Zeilen
            If .Cells(loZeile, 1).EntireRow.Hidden = False Then _
                .Range("E1:J" & loZeile).Copy Worksheets("Tabelle2").Range("A1")
        Next loZeile
    End With
    Application.ScreenUpdating = True
End Sub

Kopiert wird aus Tabelle1 Spalten E:J der mit Autofilter gefilterten Zeilen nach Tabelle2 beginnend ab Zelle A1. Vielleicht hilft dir dieser Code als Ansatz weiter.

Bis später,
Karin

Antwort 2 von fedjo

Hallo Karin,
Danke für die Hilfe!!!!

Ich habe die Tabelle hochgeladen:

http://www.netupload.de/detail.php?img=a919ef58826c60e30502dff4dd95...

Erklärung:
Tabelle (MW) Autofilter (B4)
Erste sichtbare Zelle nach Autofilter (Lieferant) kopieren.
Tabelle (Auswerten) erste leere Zelle in A finden u. einfügen.
Tabelle (MW) E2:J2 kopieren u. Tabelle (Auswerten) erste leer Zelle in B finden u. einfügen.
Tabelle (Auswerten) sortieren nach Spalte A Lieferant.
Tabelle (MW)

Gruß
fedjo

Antwort 3 von fedjo

Hallo Karin,
ich habe in den Cote
Zitat:
Application.ScreenUpdating = False
eingefügt,
und dadurch ereicht das die Ansichten nicht mehr wechseln.
Könnte man den Ablauf des Makros nicht automatisieren und die Tabelle auswerten bis zum Ende der Einträge im Autofilter?

Gruß
fedjo

Sub Mittelwert()
Application.ScreenUpdating = False
Sheets("MW").Range("B5:B65536").Cells.SpecialCells(xlCellTypeVisible)(1).Copy
Sheets("Auswerten").Select
Range("A65536").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column).Activate
ActiveSheet.Paste
Sheets("MW").Range("E2:J2").Copy
Sheets("Auswerten").Select
Range("B65536").End(xlUp).Select
Cells(ActiveCell.Row + 1, ActiveCell.Column).Activate
Selection.PasteSpecial Paste:=xlValues, Operation:=xlNone, SkipBlanks:= _
False, Transpose:=False
Range("A2:G500").Select
Selection.Sort Key1:=Range("A3"), Order1:=xlAscending, Header:=xlGuess, _
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Range("A1").Select
Sheets("MW").Select
End Sub

Antwort 4 von Beverly

Hi Fedjo,

ich habe erst einmal deinen ersten Code ein wenig umgeschreiben. Auch wenn du die Bildschirmaktualisierung ausschaltest, verlangsamen alle Select und Activate den Code z.T. wesentlich. Deshalb sollte man nach Möglichkeit darauf verzichten und zu 99% kann man das auch

Sub Mittelwert()
    Dim loLetzte As Long
    Dim loZeile As Long
    loLetzte = IIf(IsEmpty(Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 5)), Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 5).End(xlUp).Row, Worksheets("Auswerten").Rows.Count)
    With Worksheets("MW")
        loZeile = .Range("B5:B65536").Cells.SpecialCells(xlCellTypeVisible)(1).Row ´.Copy
        Union(.Range("B" & loZeile), .Range("E" & loZeile & ":J" & loZeile)).Copy Worksheets("Auswerten").Cells(loLetzte + 1, 1)
        loLetzte = IIf(IsEmpty(.Cells(.Rows.Count, 5)), .Cells(.Rows.Count, 5).End(xlUp).Row, .Rows.Count)
        .Range("A2:G" & loLetzte).Sort Key1:=Range("A2"), Header:=xlYes
    End With
End Sub


Deine neuerliche Frage verstehe ich nicht ganz. Wenn ich das richtig gesehen habe, gibt es jeden Lieferanten nur ein Mal, weshalb dann "bis zum Ende des Autofilters"? Es wird doch immer nur einer angezeigt.

Bis später,
Karin

Antwort 5 von fedjo

Hallo Karin,
die Zeile
Zitat:
loZeile = .Range("B5:B65536").Cells.SpecialCells(xlCellTypeVisible)(1).Row ´.Copy
wird rot angzeigt.

Der Autofilter sollte automatisch durchlaufen, und die gefilterten Werte (MW u. Lieferant) in die Tabelle (Auswerten) übertragen werden.

Gruß
fedjo

Antwort 6 von Beverly

Hi Fedjo,

der Teil hinter .Row ist der auskommentierte Teil deines Ursprungscodes und der Apostroph wird häufig beim Kopieren aus dem Forum falsch übertragen.

Hier der erweiterte Code

Sub Mittelwert()
    Dim loLetzte1 As Long
    Dim loLetzte2 As Long
    Dim loZeile As Long
    Application.ScreenUpdating = False
    loLetzte2 = IIf(IsEmpty(Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 5)), Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 5).End(xlUp).Row, Worksheets("Auswerten").Rows.Count)
    With Worksheets("MW")
        loLetzte1 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
        For loZeile = 5 To loLetzte1
            If .Cells(loZeile, 1).EntireRow.Hidden = False Then
                loLetzte2 = loLetzte2 + 1
                Union(.Range("B" & loZeile), .Range("E" & loZeile & ":J" & loZeile)).Copy Worksheets("Auswerten").Cells(loLetzte2, 1)
            End If
        Next loZeile
    End With
    Worksheets("Auswerten").Activate
    With ActiveSheet
        loLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 5)), .Cells(.Rows.Count, 5).End(xlUp).Row, .Rows.Count)
        .Range("A2:G" & loLetzte2).Sort Key1:=Range("A2"), Header:=xlYes
    End With
    Worksheets("MW").Activate
    Application.ScreenUpdating = True
End Sub


Bis später,
Karin

Antwort 7 von fedjo

Hallo Karin,
Danke für die Antwort!
Es werden aber andere Werte übertragen.


Übertragungswerte Tabelle (MW):
Autofilter Lieferant (B4) erst gefüllte Zelle
Werte aus E2:J2 (Funktionen)


Gruß
fedjo

Antwort 8 von Beverly

Hi Fedjo,

Sub Mittelwert()
    Dim loLetzte1 As Long
    Dim loLetzte2 As Long
    Dim loZeile As Long
    Application.ScreenUpdating = False
    loLetzte2 = IIf(IsEmpty(Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 1)), Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 1).End(xlUp).Row, Worksheets("Auswerten").Rows.Count)
    With Worksheets("MW")
        loLetzte1 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
        For loZeile = 5 To loLetzte1
            If .Cells(loZeile, 1).EntireRow.Hidden = False Then
                loLetzte2 = loLetzte2 + 1
                Union(.Range("B" & loZeile), .Range("E" & loZeile & ":J" & loZeile)).Copy Worksheets("Auswerten").Cells(loLetzte2, 1)
            End If
        Next loZeile
    End With
    Worksheets("Auswerten").Activate
    With ActiveSheet
        loLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 1)), .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
        .Range("A2:G" & loLetzte2).Sort Key1:=Range("A2"), Header:=xlYes
    End With
    Worksheets("MW").Activate
    Application.ScreenUpdating = False
End Sub


Es war ein Fehler beim Ermitteln der letzten belegten Zelle, da ich in der falschen Spalte habe suchen lassen. Jetzt sollte es funktionieren.

Noch einen Tipp: lösche alle Zeilen unterhalb deiner letzten Eingabe. Irgendwo befinden sich noch Steuerzeichen in der Tabelle, die sie so nutzlos umfangreich macht. Kannst diesen Code verwenden

Sub loeschen()
    Range("A61:IV65536").EntireRow.Delete
End Sub


Bis später,
Karin

Antwort 9 von fedjo

Hallo Karin,
es werden mehrere Einträge vom einem Lieferanten (Föhl) übertragen.

Zitat:
Übertragungswerte Tabelle (MW):
Autofilter Lieferant (B4) erst gefüllte Zelle
Werte aus E2:J2 (Funktionen)


Gruß
fedjo

Antwort 10 von Beverly

Hi Fedjo,

jetzt verstehe ich gar nichts mehr! Ich hatte einen Code geschrieben, bei dem die erste Zeile übertragen wird. Danach schreibst du, dass der Autofilter automatisch durchlaufen werden soll. Der Code, den ich anschließend gepostet habe, überträgt alle per Autofilter ausgewählten Datensätze eines Kunden. Und jetzt mit einem Mal doch wieder nur die erste Zeile? Was soll denn dann nun "automatisch durchlaufen" werden mit dem Autofilter?

Bis später,
Karin

Antwort 11 von fedjo

Hallo Karin,
ich möchte ich noch mal für deine Hilfe und Ausdauer bedanken!

Meine Frage mit dem Autofilter der automatisch durchlaufen soll, habe ich vielleicht falsch gestellt.


Übertragen sollte nur der Name des Lieferanten (Autofilter)
und der Mittelwert aus den Zellen (E2:J2) da hier eine Funktion hinterlegt ist.

Autofilter automatisch durchlaufen:
Wenn mit dem Autofilter der erste Datensatz eines Lieferanten gefiltert, kopiert (Name, E2:J2) in die Tabelle (Auswerten) eingefügt ist, sollte er automatisch den nächsten Datensatz eines Lieferanten aufrufen, kopieren usw
bis zum Ende aller Filtersätze aus dem Autofilter übertragen wurden.

Gruß
fedjo

Antwort 12 von Beverly

Hi Fedjo,

das ist für mich ein Widerspruch: weshalb soll der Name des Lieferanten mehrfach zusammen mit dem Mittelwert kopiert werden? Der Mittelwert bleibt doch immer gleich.

Sub Mittelwert()
    Dim loLetzte1 As Long
    Dim loLetzte2 As Long
    Dim loZeile As Long
    Application.ScreenUpdating = False
    loLetzte2 = IIf(IsEmpty(Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 5)), Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 5).End(xlUp).Row, Worksheets("Auswerten").Rows.Count)
    With Worksheets("MW")
        loLetzte1 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
        .Range("B" & loLetzte1).Copy Worksheets("Auswerten").Cells(loLetzte2 + 1, 1)
        .Range("E2:J2").Copy
        Worksheets("Auswerten").Range(Cells(loLetzte2 + 1, 2), Cells(loLetzte2 + 1, 7)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
    End With
    Worksheets("Auswerten").Activate
    With ActiveSheet
        loLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 5)), .Cells(.Rows.Count, 5).End(xlUp).Row, .Rows.Count)
        .Range("A2:G" & loLetzte2).Sort Key1:=Range("A2"), Header:=xlYes
    End With
    Worksheets("MW").Activate
    Application.ScreenUpdating = False
End Sub


Oder meinst du, dass der Autofilter automatisch gesetzt und alle Lieferanten einschließlich ihres Mittelwertes übertragen werden sollen, sodass am Ende eine zusammengefasste Tabelle aller Lieferanten einschließlich Mittelwert entsteht?

Bis später,
Karin

Antwort 13 von fedjo

Hallo Karin,
hier wird ein Fehler angzeigt:
Zitat:
xlPasteValuesAndNumberFormats


Genau so habe ich das gemeint:

Zitat:
Oder meinst du, dass der Autofilter automatisch gesetzt und alle Lieferanten einschließlich ihres Mittelwertes übertragen werden sollen, sodass am Ende eine zusammengefasste Tabelle aller Lieferanten einschließlich Mittelwert entsteht?


Gruß
fedjo

Antwort 14 von Beverly

Hi Fedjo,

hier der geänderte Code

Sub Mittelwert()
    Dim loLetzte1 As Long
    Dim loLetzte2 As Long
    Dim loZeile As Long
    Application.ScreenUpdating = False
    loLetzte2 = IIf(IsEmpty(Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 5)), Worksheets("Auswerten").Cells(Worksheets("Auswerten").Rows.Count, 5).End(xlUp).Row, Worksheets("Auswerten").Rows.Count)
    With Worksheets("MW")
        loLetzte1 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row
        .Range("B" & loLetzte1).Copy Worksheets("Auswerten").Cells(loLetzte2 + 1, 1)
        .Range("E2:J2").Copy
    End With
    Worksheets("Auswerten").Activate
    With ActiveSheet
        loLetzte2 = IIf(IsEmpty(.Cells(.Rows.Count, 5)), .Cells(.Rows.Count, 5).End(xlUp).Row, .Rows.Count)
        .Range(Cells(loLetzte2 + 1, 2), Cells(loLetzte2 + 1, 7)).PasteSpecial Paste:=xlPasteValuesAndNumberFormats
        .Range("A2:G" & loLetzte2).Sort Key1:=Range("A2"), Header:=xlYes
    End With
    Worksheets("MW").Activate
    Application.ScreenUpdating = False
End Sub


Ich habe schon eine ganze Menge Zeit in die Lösung deines Problems investiert und dir mehrere Codes gepostet. Wäre von Anfang an die Aufgabenstellung klar beschrieben gewesen, hätte ich einen anderen Lösungsweg als mit Autofilter eingeschlagen. Jetzt noch einmal komplett von vorne zu beginnen ist mir zu aufwendig. Vielleicht kann dir ja jemand anderes helfen.

Bis später,
Karin

Antwort 15 von fedjo

Hallo Karin,

ich hatte versucht mein Problem so gut wie möglich zu beschreiben. Dein Code funktioniert super, habe in so in meine Tabelle eingefügt.

Ich danke dir noch mal für deine Hilfe und Ausdauer.

Gruß
fedjo