Daten aus mehreren Dateien kopieren VBA
08.12.2015 17:11:40
Andre
Hallo,
mit dem folgenden Makro ziehe ich mir aus mehreren Dateien Daten aus mehreren Zellen.
Wie kann ich es hinbekommen,das ich nicht nur eine Zeile sondern 9 zeilen die untereinander stehen übertrage, dann die nächste Datei öffne, wieder die 9 Zeilen übertrage, usw, bis alle Dateien im Ordner gelesen wurden?
Sub kopieren()
'Makro zum Öffnen aller Dateien eines Zielverzeichnisses
'Die Daten aus den Dateien Rapporte Tabelle1
'werden in Zieldatei (diese Datei)
'die Daten jeder Datei werden in eine eigene Zeile geschrieben
' Variablen deklarieren
Dim datei As String
Dim Pfad As String
Dim i As Integer
i = 4
'Quellordner wird festgelegt
Pfad = getFolderName & "\"
'pfad = "L:.......\"
' Dateien des Quellordners ermitteln
datei = Dir(Pfad)
Application.ScreenUpdating = False
' Schleife, um jede Datei auszulesen
Do While datei <> ""
' Datei öffnen (Pfad wird aus den Variablen pfad und datei zusammengesetzt
Workbooks.Open Filename:=Pfad & datei
' Zählvariable für die Zeilen (je Datei eine neue Zeile)
i = i + 1
' Cells wird wie folgt verwendet Cells(Zeilennummer, Spaltennummer)
' Wenn das Makro in der Zieldatei steht, kann die Datei ThisWorkbook genannt werden.
' Die erste Zahl in der Klammer zeigt die Zeile, die zweite die Spalte
ThisWorkbook.Sheets("Tabelle2").Cells(i, 3) = ActiveWorkbook.Sheets("Tabelle1").Cells( _
67, 22)
ThisWorkbook.Sheets("Tabelle2").Cells(i, 4) = ActiveWorkbook.Sheets("Tabelle1").Cells( _
67, 23)
ThisWorkbook.Sheets("Tabelle2").Cells(i, 5) = ActiveWorkbook.Sheets("Tabelle1").Cells( _
67, 24)
' Datei schließen, ohne Änderungen zu speichern
ActiveWorkbook.Close savechanges:=False
' neue Datei aus dem Ordner lesen
datei = Dir()
' Ende der Schleife
Loop
Application.ScreenUpdating = True
End Sub
Function getFolderName()
Dim AppShell As Object
Dim BrowseDir As Variant
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
On Error Resume Next
getFolderName = BrowseDir.items().Item().Path
On Error GoTo 0
End Function
Besten Dank für die Hilfe
André