Spalte aus mehreren Dateien nebeneinander kopieren

Sub MWTabellenAusMehrerenDateienEinlesen() Dim oTargetSheet As Worksheet, oTargetRange As Range Dim oSourceBook As Workbook Dim sPfad As String Dim sDatei As String Dim lngColumns As Long Application.ScreenUpdating = False 'Das "Flackern" ausstellen 'Schritt 1: Neues Arbeitsblatt für die Ergebnisse erstellen Set oTargetSheet = ActiveWorkbook.Sheets.Add 'Schritt 2: Schleife über alle Excel Dateien in einem Verzeichnis sPfad = "C:\TEST\Sammlung\" sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien Do While sDatei "" 'Schritt 3: öffnen der Datei und Datenübertragung Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend öffnen 'Datenübertragung alle genutzten Zeilen und Spalten Set oTargetRange = oTargetSheet.Cells(1, Columns.Count).End(xlToLeft).Offset(, 2) lngColumns = oSourceBook.Sheets("Tabelle1").Cells(1, 1).CurrentRegion.Columns.Count oSourceBook.Sheets("Tabelle1").Cells(1, 1).CurrentRegion.Copy oTargetRange oTargetRange.EntireColumn.SpecialCells(xlCellTypeBlanks).Resize(, lngColumns).Delete 'Schritt 4: Datei wieder zu machen und nächste Schleifenrunde oSourceBook.Close False 'nicht speichern 'Nächste Datei sDatei = Dir() Loop Application.ScreenUpdating = True 'Das Bildschirm-Aktualisieren wieder einschalten 'Variablen aufräumen Set oTargetSheet = Nothing Set oSourceBook = Nothing End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Sub MWTabellenAusMehrerenDateienEinlesen() Dim oTargetSheet As Worksheet Dim oSourceBook As Workbook Dim sPfad As String Dim sDatei As String Application.ScreenUpdating = False 'Schritt 1: Neues Arbeitsblatt f?r die Ergebnisse erstellen Set oTargetSheet = ActiveWorkbook.Sheets.Add 'Schritt 2: Schleife ?ber alle Excel Dateien in einem Verzeichnis sPfad = "C:\Testordner\" sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien x = 1 Do While sDatei "" 'Schritt 3: ?ffnen der Datei und Daten?bertragung If Not sDatei Like "*Masterdatei*" Then Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend ?ffnen 'Daten?bertragung alle genutzten Zeilen und Spalten With oTargetSheet .Cells(1, x) = oSourceBook.Name .Range(.Cells(2, x), .Cells(31, x)).Value = oSourceBook.Worksheets(1).Range("B14: _ B43").Value End With 'Schritt 4: Datei wieder zu machen und n?chste Schleifenrunde oSourceBook.Close False 'nicht speichern x = x + 1 'N?chste Datei End If sDatei = Dir() Loop Application.ScreenUpdating = True 'Variablen aufr?umen Set oTargetSheet = Nothing Set oSourceBook = Nothing End Sub

Sub MehrereSpaltenKopieren() Dim oTargetSheet As Worksheet Dim oSourceBook As Workbook Dim sPfad As String Dim sDatei As String Dim x As Long Application.ScreenUpdating = False 'Schritt 1: Neues Arbeitsblatt fuer die Ergebnisse erstellen Set oTargetSheet = Worksheets("hier hin") 'Schritt 2: Schleife ueber alle Excel Dateien in einem Verzeichnis sPfad = "C:\TEST\Sammlung\" sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien x = 2 Do While sDatei "" 'Schritt 3: oeffnen der Datei und Datenuebertragung If Not sDatei Like "Masterdatei" Then Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend oeffnen 'Datenuebertragung alle genutzten Zeilen und Spalten With oTargetSheet .Cells(1, x) = Left(oSourceBook.Name, Len(oSourceBook.Name) - 4) 'Dateinamen Minus _ 4 Zeichen .Range(.Cells(2, x), .Cells(31, x)).Value = oSourceBook.Worksheets(1).Range("B14: _ B43").Value 'Zelle 3 bis 32 Werte aus B14:B43 'Mehrere Spalten = .Range(.Cells(3, x), .Cells(32, x + 1)).Value = oSourceBook. _ Worksheets(1).Range("B14:C43").Value 'bis B14:C43 End With 'Schritt 4: Datei wieder zu machen und naechste Schleifenrunde oSourceBook.Close False 'nicht speichern x = x + 1 'Abstand zur nächsten Datei 'Naechste Datei End If sDatei = Dir() Loop Application.ScreenUpdating = True 'Variablen aufraeumen Set oTargetSheet = Nothing Set oSourceBook = Nothing End Sub

Hallo Boris, ich bin begeistert. Das Script funktioniert so, wie ich es brauche. Vielen Dank.
Ich habe noch die Zeile "Set oTargetSheet = Worksheets("hier hin")" angespasst, damit die Werte immer in der vorhandenen Tabelle "Hier hin" geschrieben werden.
Dann noch den Wert für X auf 2 geändert, damit ich in der Spalte A noch Platz für eine Beschreibungen habe.
Und zuletzt für die erste Zelle beim SourceBook.Namen noch 4 Zeichen für die Dateiendung entfernen lassen.
Ist das so alles korrekt umgesetzt?
Und ist es möglich für "sPfad" den aktuellen Pfad der Excel-Datei zu verwenden? "ThisWorkbook.Path" hat leider nicht funktioniert.
Ein Problem habe ich dann aber noch. In den Quell-Dateien sind auch Scripte hinterlegt, die ich Leider nicht entfernen kann. Wenn die Quell-Dateien mit aktivierten Makros geöffnet werden, dann bekomm ich bei jeder Datei folgende Fehlermeldung:

Unable to locate ReportINI sheet. Please make sure, ReportINI.xls is in the -xlstart- subdirectory of the -office- program.

Ich musste dann heute für 90 Dateien 90x mit "ok" bestätigen, um das Script durchlaufen zu lassen. Kann man die Quell-Dateien mit deaktivierten Makros öffnen oder die Bestätigung automatisieren?
Der ganze Code sieht nun so aus:

Sub MehrereSpaltenKopieren()
Dim oTargetSheet As Worksheet
Dim oSourceBook As Workbook
Dim sPfad As String
Dim sDatei As String
Dim x As Long
Application.ScreenUpdating = False
'Schritt 1: Neues Arbeitsblatt fuer die Ergebnisse erstellen
Set oTargetSheet = Worksheets("hier hin")
'Schritt 2: Schleife ueber alle Excel Dateien in einem Verzeichnis
sPfad = "C:\TEST\Sammlung\"
sDatei = Dir(CStr(sPfad & "*.xl*")) 'Alle Excel Dateien
x = 2
Do While sDatei  ""
'Schritt 3: oeffnen der Datei und Datenuebertragung
If Not sDatei Like "Masterdatei" Then
Set oSourceBook = Workbooks.Open(sPfad & sDatei, False, True) 'nur lesend oeffnen
'Datenuebertragung alle genutzten Zeilen und Spalten
With oTargetSheet
.Cells(1, x) = Left(oSourceBook.Name, Len(oSourceBook.Name) - 4) 'Dateinamen Minus   _
_
4 Zeichen
.Range(.Cells(2, x), .Cells(31, x)).Value = oSourceBook.Worksheets(1).Range("B14: _
B43").Value 'Zelle 3 bis 32 Werte aus B14:B43
'Mehrere Spalten = .Range(.Cells(3, x), .Cells(32, x + 1)).Value = oSourceBook. _
Worksheets(1).Range("B14:C43").Value 'bis B14:C43
End With
'Schritt 4: Datei wieder zu machen und naechste Schleifenrunde
oSourceBook.Close False 'nicht speichern
x = x + 1 'Abstand zur nächsten Datei
'Naechste Datei
End If
sDatei = Dir()
Loop
Application.ScreenUpdating = True
'Variablen aufraeumen
Set oTargetSheet = Nothing
Set oSourceBook = Nothing
End Sub

Beliebteste Forumthreads (12 Monate)

Spalte aus mehreren Dateien nebeneinander kopieren

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

Spalte aus mehreren Dateien nebeneinander kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

300 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread