Supportnet / Forum / Tabellenkalkulation
mehrer Arbeitsmappen in eine neue Arbeitsmappe in Tabelle 1 untereinander kopieren
Frage
Hallo,
ich habe mehrere EXCEL-Dateien unter einem Ordner "DATEIEN". Diese sollen automatisch in einer neuen Arbeitsmappe "Zusammenfuehrung_25.10.06.xls" in der "Tabelle 1" untereinander weggeschrieben werden. Mit u.s. Makro habe ich es geschaftt, daß alle Dateien in o.g. Arbeitsmappe ünertragen werden, aber jede Datei wird in ein anderes Tabellenblatt ("Tabelle 1(2), Tabelle 1 (3) etc.") geschrieben. Wie kann ich das Makro ändern bzw. ihr könnt es auch ganz neu schreiben, daß alle Dateien im Tabellenblatt 1 untereinander stehen.
Danke für die Hilfe.
Makro:
Sub konsolidierung()
Dim Mappe As String
Dim i As Integer
Const LW = "C:\"
Const Pfad = "C:\Betti\DATEIEN\" ´hier stehen die Dateien
ChDrive LW
ChDir Pfad
Application.SheetsInNewWorkbook = 1
Workbooks.Add
ActiveWorkbook.SaveAs ("C:\Betti\Dateien\Zusammenfuehrung_25.10.06.xls")
Mappe = Dir(Pfad & "*.xls")
ChDir (Pfad)
Do While Mappe <> ""
Workbooks.Open Mappe
For i = 1 To Workbooks(Mappe).Sheets.Count
Workbooks(Mappe).Sheets(i).Copy Before:=Workbooks("Zusammenfuehrung_25.10.06.xls").Sheets(1)
Next i
Workbooks(Mappe).Close savechanges:=False
Mappe = Dir
Loop
End Sub
Antwort 1 von coros
Hallo Betti,
mal ungetestet geändert.
Versuche es erst mal an einer Kopie Deiner Datei, da ich wie schon oben geschrieben habe, das Makro nicht getetstet habe.
Bei Fragen melde Dich bitte wieder.
MfG,
Oliver
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.
mal ungetestet geändert.
Sub konsolidierung()
Dim Mappe As String
Dim i As Integer
Const LW = "C:\"
Rem:hier stehen die Dateien
Const Pfad = "C:\Betti\DATEIEN\"
ChDrive LW
ChDir Pfad
Application.SheetsInNewWorkbook = 1
Workbooks.Add
ActiveWorkbook.SaveAs ("C:\Betti\Dateien\Zusammenfuehrung_25.10.06.xls")
Mappe = Dir(Pfad & "*.xls")
ChDir (Pfad)
Do While Mappe <> ""
Workbooks.Open Mappe
For i = 1 To Workbooks(Mappe).Sheets.Count
Workbooks(Mappe).Sheets(i).Cells.Copy _
Workbooks("Zusammenfuehrung_25.10.06.xls").Sheets(1).Range("A" & Workbooks("Zusammenfuehrung_25.10.06.xls").Sheets(1).Range("A65536").End(xlUp).Offset(1, 0).Row)
Next i
Workbooks(Mappe).Close savechanges:=False
Mappe = Dir
Loop
End Sub
Versuche es erst mal an einer Kopie Deiner Datei, da ich wie schon oben geschrieben habe, das Makro nicht getetstet habe.
Bei Fragen melde Dich bitte wieder.
MfG,
Oliver
Da hier der einzige Lohn für die Helfer eine Rückmeldung ist, wäre es nett, wenn Du ein
Feedback abgeben könntest, ob der Lösungsvorschlag Dein Problem gelöst hat.