Werte aus mehreren Tabellenblättern kopieren

Informationen und Beispiele zu den hier genannten Dialog-Elementen:
Bild

Betrifft: Werte aus mehreren Tabellenblättern kopieren
von: Kai Thomas
Geschrieben am: 15.09.2015 16:18:01

Hallo zusammen,
ich nutze ein Makro um aus mehreren Tabellenblättern ein einziges zu erstellen.
Die Quelldateien haben bis zu 50.000 Zeilen sodass sich eine Menge Daten ergeben und das Makro sehr lange läuft. Allerdings sind dort viele Werte mit Null enthalten, die ich in der Zieldatei gar nicht haben möchte. Kann mir jemand dabei helfen, bzw. ist es möglich die Werte nur in das Array zu schreiben, wenn der Wert der zu kopierenden Zeile in Spalte M der Ausgangsdatei größer oder kleiner 0 ist?


Option Explicit
Sub Ordner_suchen()
Dim dat
Dim ordner
Dim datein
Dim fso
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Ein Array mit 1000000 Zeilen und 13 Spalten.
'Dient zur späteren Aufnahme der Werte.
Dim arr(1000000, 13)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXX
Dim L As Long
Dim Z As Long
Dim WB
Dim dsplalert As Boolean
Dim cal
Dim scrup As Boolean
Dim ev As Boolean
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Zum Beschleunigen des Makros
With Application
    dsplalert = .DisplayAlerts
    cal = .Calculation
    scrup = .ScreenUpdating
    ev = .EnableEvents
    .DisplayAlerts = False              'Excelinterne Meldungen aus
    .Calculation = xlCalculationManual  'Automatische Berechnung aus
    .ScreenUpdating = False             'Bildschirm aktualisierung aus
    .EnableEvents = False               'Makrostarts aus
End With
'XXXXXXXXXXXXXXXXXXXXXXXXXXX
'Überschriften ins Array schreiben
arr(L, 0) = "1"
arr(L, 1) = "2"
arr(L, 2) = "3"
arr(L, 3) = "4"
arr(L, 4) = "5"
arr(L, 5) = "6"
arr(L, 6) = "7"
arr(L, 7) = "8"
arr(L, 8) = "9"
arr(L, 9) = "10"
arr(L, 10) = "11"
arr(L, 11) = "12"
arr(L, 12) = "13"
L = L + 1
'XXXXXXXXXXXXXXXXXXXXXXXXXXX
'Dialog aufrufen
'Die innere IF-Then Konstruktion fängt "Abbrechen" in dem Dialog ab.
Set dat = Application.FileDialog(msoFileDialogFolderPicker)
With dat
   .Title = "Test kopieren"
   .InitialFileName = "C:\" 'oder was auch immer
nochmal:
If .Show = -1 Then
    ordner = .SelectedItems(1)
Else:
    If MsgBox("Ordner auswählen vergessen." & vbCrLf & "Nochmal ?", vbYesNo) = vbYes Then
    GoTo nochmal
    Else:
        GoTo raus
    End If
End If
End With
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Zugriff aus Dateisystem
Set fso = CreateObject("Scripting.filesystemobject")
Set datein = fso.getfolder(ordner)
'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Sucht jedes file in Ordner.
'i istdie Variable
For Each WB In datein.Files
    If WB.Name Like "*.xlsx" Then 'selbserklärend
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
        Workbooks.Open WB        'selbserklärend
        'Jetzt wird die eigentliche Arbeit gemacht.
        'z ist eine Variable über Zeilen.
        'Sheets(1).Range("b100000").End(xlUp).Row ist die
        'Zeilennummer der letzten beschriebenen Zelle in SpalteB
        'von WB.sheets(1).
        For Z = 27 To Sheets(1).Range("b100000").End(xlUp).Row
                arr(L, 0) = Sheets(1).Cells(Z, 2).Text
                'schreibt den Wert aus cells(zeile=z,Spalte=1) ins Array an Position
                'Zeile=2 und Spalte =1
                arr(L, 1) = Sheets(1).Cells(Z, 3).Text
                'schreibt den Wert aus cells(zeile=z,Spalte=3) ins Array an Position
                'Zeile=2 und Spalte =2
                arr(L, 2) = Sheets(1).Cells(Z, 4).Text
                arr(L, 3) = Sheets(1).Cells(Z, 5).Text
                arr(L, 4) = Sheets(1).Cells(Z, 6).Text
                arr(L, 5) = Sheets(1).Cells(Z, 7).Text
                arr(L, 6) = Sheets(1).Cells(Z, 8).Text
                arr(L, 7) = Sheets(1).Cells(Z, 9).Text
                arr(L, 8) = Sheets(1).Cells(Z, 10).Text
                arr(L, 9) = Sheets(1).Cells(Z, 11).Text
                arr(L, 10) = Sheets(1).Cells(Z, 12).Text
                arr(L, 11) = Sheets(1).Cells(Z, 13).Text
                arr(L, 12) = WB.Name
                L = L + 1
        Next
        Workbooks(WB.Name).Close False
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
    End If
Next
Range("A:M") = arr 'Alle Werte auf einmal in die Tabelle übertragen
raus:
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'Die Eingangs gemachten Einstellungen Rückgängig machen
With Application
     .DisplayAlerts = dsplalert
     .Calculation = cal
     .ScreenUpdating = scrup
     .EnableEvents = ev
End With
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
End Sub
Private Sub CommandButton1_Click()
Call Ordner_suchen
End Sub

Viele Grüße und vielen Dank für jegliche Hilfe
Kai

Bild

Betrifft: AW: Werte aus mehreren Tabellenblättern kopieren
von: Kai Thomas
Geschrieben am: 16.09.2015 09:13:42
Hallo zusammen,
sorry für die einfache Frage, eine Nacht drüber schlafen hat gereicht um die Lösung selbst zu finden:


For Each WB In datein.Files
    If WB.Name Like "*.xlsx" Then 'selbserklärend
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
        Workbooks.Open WB        'selbserklärend
        'Jetzt wird die eigentliche Arbeit gemacht.
        'z ist eine Variable über Zeilen.
        'Sheets(1).Range("b100000").End(xlUp).Row ist die
        'Zeilennummer der letzten beschriebenen Zelle in SpalteB
        'von WB.sheets(1).
        For Z = 27 To Sheets(1).Range("b100000").End(xlUp).Row
            If Sheets(1).Cells(Z, 12) <> 0 Then
                arr(L, 0) = Sheets(1).Cells(Z, 2).Text
                'schreibt den Wert aus cells(zeile=z,Spalte=1) ins Array an Position
                'Zeile=2 und Spalte =1
                arr(L, 1) = Sheets(1).Cells(Z, 3).Text
                'schreibt den Wert aus cells(zeile=z,Spalte=3) ins Array an Position
                'Zeile=2 und Spalte =2
                arr(L, 2) = Sheets(1).Cells(Z, 4).Text
                arr(L, 3) = Sheets(1).Cells(Z, 5).Text
                arr(L, 4) = Sheets(1).Cells(Z, 6).Text
                arr(L, 5) = Sheets(1).Cells(Z, 7).Text
                arr(L, 6) = Sheets(1).Cells(Z, 8).Text
                arr(L, 7) = Sheets(1).Cells(Z, 9).Text
                arr(L, 8) = Sheets(1).Cells(Z, 10).Text
                arr(L, 9) = Sheets(1).Cells(Z, 11).Text
                arr(L, 10) = Sheets(1).Cells(Z, 12).Text
                arr(L, 11) = Sheets(1).Cells(Z, 13).Text
                arr(L, 12) = WB.Name
                L = L + 1
            End If
        Next
        Workbooks(WB.Name).Close False
        'XXXXXXXXXXXXXXXXXXXXXXXXXXXX
    End If
Next
Gruß Kai

 Bild

Beiträge aus den Excel-Beispielen zum Thema "Werte aus mehreren Tabellenblättern kopieren"