Excel Dateien aus verschiedenen Ordnern zusammenfassen

Question

Hallo zusammen,

ich habe folgendes Problem:
Es gibt 5 Ordner. Pfade:
G:\SSM\Bereich 1\Kundenlisten
bis
G:\SSM\Bereich 5\Kundenlisten

In jedem ist eine unbekannte Anzahl an Excel Dateien (überwiegend .xlsm Dateien).
Die Dateien sind alle identisch aufgebaut, haben aber unterschiedliche Namen. In dem ersten Arbeitsblatt je Datei befindet sich eine Tabelle (je Datei identisch aufgebaut, Einträge von Spalte A bis Z, aber unterschiedliche Anzahl Zeilen). Es gibt noch ein zweites Arbeitsblatt in der Datei, dieses ist aber zu ignorieren.

Die Überschrift befindet sich in Zeile 1-3. Ich bräuchte bitte ein Makro mit dem ich die Einträge (beginnen ab Zeile 4) auslese (ohne die Überschriften und die leeren Zeilen) und in einer neuen Datei ("Konsolidierung", diese befindet sich in einem anderen Ordner/Laufwerk) zusammenfüge. In den Quelldateien sollen die Einträge bestehen bleiben. Also nur heraus-kopieren.

Die Datei "Konsolidierung" sollte 6 Arbeitsblätter haben. Eines je Bereich und ein Gesamtblatt (dort stehen die Einträge aller Bereiche).

Was VBA angeht bin ich eher grobmotorisch veranlagt. Habe bei meiner Recherche ähnlich Makros gefunden aber leider nichts wirklich passendes. Zumindest nicht so, dass ich es anpassen könnte. Wäre super wenn mir jemand bei dem Problem helfen könnte.

Vielen Dank vorab und freundliche Grüße

Michael

Answer 1

hi ff ^^

ein anfang vielleicht
vorrausgesetzt die ordner sind bekannt

gruss nighty

Pfad wie ord1 ord2 etc ist anzupassen

Sub WorksheetCopyWerte()
Call EventsOff
Dim DateiName As String, OrdName As String
Dim wbMappe As Workbook
For Each OrdName In Array("ord1", "ord2", "ord3", "ord4", "ord5", "ord6")
DateiName = Dir("D:\Temp\" & OrdName & "\" & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:="D:\Temp\" & OrdName & "\" & DateiName
ThisWorkbook.Worksheets.Add
ThisWorkbook.ActiveSheet.Name = DateiName
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets("alle").Range("A" & ThisWorkbook.Worksheets("alle").Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets(DateiName).Range("A2" & ThisWorkbook.Worksheets(DateiName).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Close SaveChanges:=True
End If
DateiName = Dir
Loop
Next t
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.DisplayAlerts = False
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 2

hi Michael

ops der Name war irgendwe weg

gruss nighty

Answer 3

hi Michael und all ^^

und hier bitte true setzen

Public Sub EventsOn()
With Application
.DisplayAlerts = False
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

gruss nighty

Answer 4

hi Michael und all

waren noch einige fejler drin

@obige bitte löschen

korrigiert

Sub WorksheetCopyWerte()
Call EventsOff
Dim DateiName As String
Dim OrdName As Variant
Dim wbMappe As Workbook
For Each OrdName In Array("ord1", "ord2", "ord3", "ord4", "ord5", "ord6")
DateiName = Dir("D:\Temp\" & OrdName & "\" & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:="D:\Temp\" & OrdName & "\" & DateiName
ThisWorkbook.Worksheets.Add
ThisWorkbook.ActiveSheet.Name = DateiName
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets("alle").Range("A" & ThisWorkbook.Worksheets("alle").Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets(DateiName).Range("A2" & ThisWorkbook.Worksheets(DateiName).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Close SaveChanges:=True
End If
DateiName = Dir
Loop
Next OrdName
Call EventsOn
End Sub

Public Sub EventsOff()
With Application
.DisplayAlerts = False
.ScreenUpdating = False
.EnableEvents = False
.Calculation = xlCalculationManual
End With
End Sub

Public Sub EventsOn()
With Application
.DisplayAlerts = True
.ScreenUpdating = True
.EnableEvents = True
.Calculation = xlCalculationAutomatic
End With
End Sub

Answer 5

Hallo Nighty,

erst mal vielen Dank für die schnelle Antwort.

Die Pfade zu den einzelnen Ordnern habe ich verändert.
Die Datei enthält je ein Arbeitsblatt für die 5 Bereiche (diese sind auch benannt wie die Bereiche: Bereich 1, Bereich 2 - Bereich 5) und das Blatt "Gesamt" in dem die Einträge aus den einzelnen Bereichen konsolidiert werden soll.

Habe das Makro "Sub WorksheetCopyWerte()" ausgeführt. Leider tut sich nichts.

Hast Du einen Tipp für mich woran das liegen könnte?

Danke vorab und beste Grüße

Michael

Answer 6

hi Michael

ich bin von 5 unterordnern ausgegangen die eine beliebige anzahl an Dateien das jeweils 1 worksheet die werte von spalte a-z ausliesst
in der activen Mappe werden worksheets mit dem namen der jeweiligen Datei generiert die Daten dann hinzugefuegt
worksheet "alle" der activen Mappe werden alle Daten angefuegt

gruss nighty

hier nochmal das startmodul korrigiert,2 fehler waren eh noch

Sub WorksheetCopyWerte()
Call EventsOff
Dim DateiName As String
Dim OrdName As Variant
'hier nur ordnernamen,keine pade
For Each OrdName In Array("ord1", "ord2", "ord3", "ord4", "ord5", "ord6")
'pfad anpassen
DateiName = Dir("D:\Temp\" & OrdName & "\" & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
'pfad anpassen
Workbooks.Open Filename:="D:\Temp\" & OrdName & "\" & DateiName
ThisWorkbook.Worksheets.Add
ThisWorkbook.ActiveSheet.Name = DateiName
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
'naechste zeile "alle" ersetzen durch deinen worksheetnanen
ThisWorkbook.Worksheets("alle").Range("A" & ThisWorkbook.Worksheets("alle").Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
ThisWorkbook.Worksheets(DateiName).Range("A" & ThisWorkbook.Worksheets(DateiName).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Close SaveChanges:=True
End If
DateiName = Dir
Loop
Next OrdName
Call EventsOn
End Sub

oder neue erklaerung wenn ich was durcheinander brachte :-)

Answer 7

Hallo Nighty,

danke für die Korrekturen.

was genau gebe ich hier als Ordnername ein?:
For Each OrdName In Array("ord1", "ord2", "ord3", "ord4", "ord5", "ord6")

Der genaue Pfad wäre:
G:\SSM\Bereich 1\Kundenlisten

Trage ich dann "Bereich 1", "Bereich 2" - "Bereich 5" ein?
(Das sind noch nicht die Ordner in denen die Quelldateien liegen, sondern ein Teil des Pfads.

Wo trage ich den Namen des Zielordners ein ("Kundenlisten")?
Ist es ein Problem wenn dieser immer gleich ist? Ich könnte sie umbenennen in "Kundenlisten 1" - "Kundenlisten 5" wenn nötig.

Wo gebe ich den Namen des Woksheets ein, in dem die einzelnen Bereiche kumuliert werden also "alle" (oder brauch ich das nicht)?

Danke vorab und beste Grüße

Michael

Answer 8

hi Michael

die pfade so vielleicht ?
G:\SSM\Bereich 1\Kundenlisten\Dateien.xls
G:\SSM\Bereich 2\Kundenlisten\Dateien.xls
G:\SSM\Bereich 3\Kundenlisten\Dateien.xls
etc.

ziel worksheet ist zur zeit

1)
"alle" mit den gesamten Daten
2)
und die neuen workshetts mit den Dateinamen der jeweiligen datei

lass uns das erst mit dem pfad hinbekommen

gruss nighty

Answer 9

hi Michael ^^

das mit den bereichen ist nun klar
haette es mir besser durchlesen muessen *g*

aendere ich in automatischer Abtastung der ordner,du kannst dann später bereichsworksheets einfach hinzufuegen

ziel waere also
1)breich1 etc
2)Name des sammelworksheets ?
wenn alle Daten nochmals zusammengefasst werden sollten ?

ansonsten nur noch die pfade klaeren

gruss nighty

Answer 10

Hallo Nighty,

ich möchte folgenden Ordner auslesen:
G:\SSM\Bereich 1\Kundenlisten

In dem Ordner Kundenlisten befinden sich mehrere Excel Dateien mit unterschiedlichen Namen (aber identischem Aufbau).
Die Namen der Excel Dateien können nicht zur Suche herangezogen werden. Der eine fügt im Namen Leerzeichen ein, der nächste Unterstriche etc..
Das Makro soll also alle Dateien in dem Ordner auslesen.

Das gleiche auf für diesen Ordner:
G:\SSM\Bereich 2\Kundenlisten

usw. bis

G:\SSM\Bereich 5\Kundenlisten

Ich brauche die Ergebnisse in einer separaten Excel Datei. Diese heißt "Konsolidierung".
Diese Datei hat 6 Blätter. "Bereich_1" - "Bereich_5" und ein Blatt " "Gesamt".

Danke vorab und beste Grüße

Michael