AW: Dateien zusammenführen
26.09.2014 22:18:47
Werner
Hallo
hatte das Problem auch, habe damals gesucht und mit Anpassung folgendem Code sehr gute Ergebnisse erreicht.
https://www.google.com/url?q=https://www.herber.de/forum/archiv/940to944/942000_Zellen_aus_nZeilen_und_nDateien_kopieren_und_in.html&sa=U&ei=HDUCVKiSBcvsaJ3DgeAM&ved=0CBIQFjAGODw&client=internal-uds-cse&usg=AFQjCNFJxdhwbuYK9Nkp52ip5oy94WjUMg
Zellen aus n-Zeilen und n-Dateien kopieren und
Hallo Simone,
hier mal das Grundgrüst um die Exceldateien zu suchen, in einer Schleife zu öffnen und bestimmte Daten aus den Blättern der Quelldateien in die Sammeldatei zu übertragen.
Da du über die zu kopierenden Zellbereich(e) keine speziellen Angaben gemacht hast, hab ich hierfür beispielhaft eine Kopierzeile eingefügt, diese müßtest du noch an deine Bedürfnisse anpassen. Ebenso ggf. die Neuberechnung der jeweils nächsten Einfügezeile (lZeileneu).
Das Makro kannst du in einer beliebigen Excel-Datei speichern. Jedoch nicht in einem der Verzeichnisse, die du auswerten willst!
Gruß
Franz
Sub DatenSammeln()
Dim wbNeu As Workbook, wksNeu As Worksheet, lZeileneu As Long
Dim wbQuelle As Workbook, wksQuelle As Worksheet, strQuelle, i As Integer
Dim strVerzeichnis, VerzAktuell As String, DateiNr As Integer
'Verzeichnis durch Wahl einer Datei wählen
VerzAktuell = VBA.CurDir
strVerzeichnis = Application.GetOpenFilename(Filefilter:="Exceldateien(*.xls),*.xls", _
Title:="Bitte Datei im gewünschten Verzeichnis wählen und öffnen")
If strVerzeichnis = False Then Exit Sub
strVerzeichnis = VBA.CurDir
VBA.ChDir VerzAktuell
With Application.FileSearch
.LookIn = strVerzeichnis
.SearchSubFolders = True
.FileType = msoFileTypeExcelWorkbooks
.Execute
Set wbNeu = Workbooks.Add(Template:=xlWBATWorksheet)
Set wksNeu = wbNeu.Worksheets(1)
lZeileneu = 1
DateiNr = 1
Application.ScreenUpdating = False
For Each strQuelle In .FoundFiles
Application.StatusBar = "Datei Nummer " & DateiNr & " von " _
& .FoundFiles.Count
Set wbQuelle = Workbooks.Open(FileName:=strQuelle, ReadOnly:=True)
'Alle Tabellenblätter in Quelle abarbeiten
For i = 1 To wbQuelle.Worksheets.Count
Set wksQuelle = wbQuelle.Worksheets(i)
wksNeu.Cells(lZeileneu, 1) = wbQuelle.FullName
wksNeu.Cells(lZeileneu, 2) = wksQuelle.Name
With wksQuelle
.Range(.Cells(2, 1), .Cells(2, 10)).Copy 'bereich A2:J2
wksNeu.Cells(lZeileneu, 3).PasteSpecial Paste:=xlFormats 'Zell-Formate
wksNeu.Cells(lZeileneu, 3).PasteSpecial Paste:=xlValues 'Zellewerte
'ggf. Code für weitere Zellbereiche ergänzen
End With
lZeileneu = lZeileneu + 1
Next i
wbQuelle.Close savechanges:=False
DateiNr = DateiNr + 1
Next strQuelle
End With
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Hoffentlich hilfts
Tschüs Werner