139635
Goto Top

Excel VBA - Zeilen aus verschiedenen Tabellenblättern unter Bedingung in ein neues Tabellenblatt kopieren

Hallo Community,

ich hänge an einem (kleinen) Problem. Ich möchte aus mehreren Tabellenblättern den Inhalt einzelner Zeilen in ein neues Tabellenblatt kopieren lassen.
Soweit bin ich auch gekommen, allerdings möchte ich in den Code noch einbringen, dass nur Zeilen kopiert werden, die in Spalte X einen Wert von 2 oder größer haben.
Außerdem wäre es gut wenn die bestehende Gruppierung der Zeilen in den originalen Tabellenblättern beim kopieren erhalten bleiben könnte.

Mein bisheriger Code:
Sub CopyMultiple()
    Dim sh As Worksheet
    Dim shDestination As Worksheet
    Dim iLast As Long
    Dim rngCopy As Range
    Dim i As Integer

    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With

    Set shDestination = ActiveWorkbook.Worksheets("Tabelle2")  

    For Each sh In ActiveWorkbook.Worksheets

'Tabellenblätter mit nicht benötigten Daten (ausgeschlossen vom Kopiervorgang)          
If IsError(Application.Match(sh.Name, _
                                     Array("Main", "Users", "HelpSheet", "Processed"), 0)) Then  


            iLast = Worksheets("Tabelle2").Cells(Cells.Rows.Count, "A").End(xlUp).Row  
            LastRow = sh.Cells(Cells.Rows.Count, "X").End(xlUp).Row  
            
            Set rngCopy = sh.Range("A3:X" & LastRow)  

            If iLast + rngCopy.Rows.Count > shDestination.Rows.Count Then
                MsgBox "Zu wenig Platz zum kopieren"  
                GoTo ExitTheSub
            End If

            rngCopy.Copy
            With shDestination.Cells(iLast + 1, "A")  
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

        End If
    Next

ExitTheSub:

    Application.Goto shDestionation.Cells(1)


    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub

Wie gesagt, der Code kopiert den gesamten Inhalt von A3 bis X(Letzte Zeile), mir fehlt irgendwo eine Funktion zum Filtern a la nimm alle gefundenen Zeilen und davon nur die, welche in Spalte X einen Wert von 2 oder größer haben und füge nur diese in Tabelle 2 ein.

Gruppierungen wären nicht zwingend nötig aber durchaus vorteilhaft, falls das überhaupt möglich ist, da hab ich nichts dazu gefunden :/
Falls es nicht möglich ist die Gruppierungen zu erhalten könnte die Lösung auch sein, Zeilen mit dem Wort "Gruppe" in Spalte Q nicht zu kopieren.

Danke euch im Voraus für eure Hilfe und ein schönes Wochenende face-smile

Gruß

Content-Key: 462684

Url: https://administrator.de/contentid/462684

Printed on: April 25, 2024 at 14:04 o'clock

Member: Volchy
Volchy Jun 17, 2019 at 12:30:36 (UTC)
Goto Top
Hallo TheMysterion,

wenn ich es nicht falsch verstanden habe und du sagst dass deine Kopierfunktion generell schon funktioniert, könntest du innerhalb deiner For-Schleife eine weitere If-Abfrage mit einbauen, die das Kopieren umschließt und für deine aktuelle Zeile auf der du stehst den Kopiervorgang übernimmt (als Kommentar markiert):

 For Each sh In ActiveWorkbook.Worksheets

'Tabellenblätter mit nicht benötigten Daten (ausgeschlossen vom Kopiervorgang)          
If IsError(Application.Match(sh.Name, _
                                     Array("Main", "Users", "HelpSheet", "Processed"), 0)) Then  


            iLast = Worksheets("Tabelle2").Cells(Cells.Rows.Count, "A").End(xlUp).Row  
            LastRow = sh.Cells(Cells.Rows.Count, "X").End(xlUp).Row  
            
            //**Variable für aktuell zu kopierende Zeile einfügen**//

            **//If-Abfrage, die dir die Spalte deiner aktuellen Zeile auf einen gewünschten Wert prüft.
            Wenn >= 2 -> dann nachstehenden Copy ausführen, Sonst Ausnahmebehandlung oder einfach zu Next//**

            Set rngCopy = sh.Range("A3:X" & LastRow)  **//LastRow durch neue Variable ersetzen, damit du deine neue passende gewünschte Zeile hast//** 

            If iLast + rngCopy.Rows.Count > shDestination.Rows.Count Then
                MsgBox "Zu wenig Platz zum kopieren"  
                GoTo ExitTheSub
            End If

            rngCopy.Copy
            With shDestination.Cells(iLast + 1, "A")  
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

        End If
    Next


Gruß
Volchy
Mitglied: 139635
139635 Jun 25, 2019 at 16:51:38 (UTC)
Goto Top
Hallo Volchy,

danke für deine Antwort. Kurze Frage... wenn ich LastRow durch eine neue Variable ersetze, dann würde doch nur noch der Bereich von A3 bis zum ersten Vorkommen von ">= 2" kopiert werden, oder nicht? Weil mein Next springt ja zum nächsten Blatt, danach.

Bisher wird ja der ganze Bereich von A3 bis z.B. X100 kopiert (wenn 100 die letzte beschriebene Zeile ist). Aus diesen 97 Zeilen möchte ich aber nur die kopieren, die in Spalte X einen Wert größer/gleich 2 haben.

Oder hab ich was falsch verstanden?

Gruß