Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1444to1448
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Werte aus mehreren Tabellenblättern kopieren

Werte aus mehreren Tabellenblättern kopieren
15.09.2015 16:18:01
Kai
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

1
Beitrag zum Forumthread
Beitrag zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Werte aus mehreren Tabellenblättern kopieren
16.09.2015 09:13:42
Kai
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
Anzeige

353 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige