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 Michael ^^

erste versuch

gruss nighty

du kannst beliebig viele ordner und worksheets mit den Bereich xxx namen erstellen
es erfolgt ein Automatismus

Sub WorksheetCopyWerte()
Call EventsOff
Dim DateiName As String, OrdName As String
Dim OrdIndex As Integer
ReDim OrtDat(OrdIndex) As String
OrdName = Dir("G:\SSM\", 16)
Do While OrdName <> ""
If Mid(OrdName, 1, 7) = "Bereich" Then
OrtDat(OrdIndex) = OrdName
OrdIndex = OrdIndex + 1
ReDim Preserve OrtDat(OrdIndex)
End If
OrdName = Dir(, 16)
Loop
For OrdIndex = 0 To UBound(OrtDat()) - 1
DateiName = Dir("G:\SSM\" & OrtDat(OrdIndex) & "\Kundenlisten\" & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:="G:\SSM\" & OrtDat(OrdIndex) & "\Kundenlisten\" & DateiName
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets("Gesamt").Range("A" & ThisWorkbook.Worksheets("Gesamt").Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
ThisWorkbook.Worksheets(OrtDat(OrdIndex)).Range("A" & ThisWorkbook.Worksheets(OrtDat(OrdIndex)).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Close SaveChanges:=True
End If
DateiName = Dir
Loop
Next OrdIndex
Call EventsOn
End Sub

Answer 2

hi nichael

dateiendung ist zur zeit .xls
bei bedarf korrigieren

gruss nighty

Answer 3

Hallo Nighty,

sorry für die späte Antwort. War leider ein paar Tage außer Gefecht gesetzt.

Wenn ich das Makro laufen lasse, wird folgende Fehlermeldung angezeigt:
"Index außerhalb des gültigen Bereichs"

Ich klicke auf OK und bin dann in der ersten Quelldatei (wurde durch das Makro geöffnet).
Es sind die Zeilen 2 und 3 der Überschrift markiert und die Zellen mit Einträgen.
Die erste Zeile ist nicht markiert.
In den ersten beiden Zeilen gibt es verbundene Zellen (z. B. sind A1 und A2 verbunden).
Ich hoffe das ist kein Problem.

Weiter geht es nicht. Es sind auch keine Veränderungen in der Konsolidierungsdatei.
Dort habe ich bisher nur ein Arbeitsblatt.
Ist ein einfacher, wenn ich die Arbeitsblätter schon so einrichte und benenne wie sie final sein sollen?

Die Quelldateien sind xlsm Dateien (habe ich so im Makro verändert).

Schon mal besten Dank für Deine Mühe!

Michael

Answer 4

hi Michael ^^

in vb werden verbundene Bereiche gemieden,gut erkannt !
du wirst auch immer wieder unangenehm auf verbundene zellen in Zukunft stossen
eigentlich sind die verboten *g*
kann mich ja mal probiren
wen es feste Bereiche sind

benenn die Bereiche z.b.
zeile1 a1+a2
zeile2 a1+a4

gruss nighty

Answer 5

hi Michael

ich bin 3 tage weg,komme erst naechste Woche dazu
denke aber duerfte kein Problem sein,hoffentlich sieht mich keiner *kicher kicher*

gruss nighty

Answer 6

hi Michael ^^

probier mal

gruss nighty

Sub WorksheetCopyWerte()
Call EventsOff
Dim DateiName As String, OrdName As String
Dim OrdIndex As Integer
Dim Zelle As Range
ReDim OrtDat(OrdIndex) As String
OrdName = Dir("G:\SSM\", 16)
Do While OrdName <> ""
If Mid(OrdName, 1, 7) = "Bereich" Then
OrtDat(OrdIndex) = OrdName
OrdIndex = OrdIndex + 1
ReDim Preserve OrtDat(OrdIndex)
End If
OrdName = Dir(, 16)
Loop
For OrdIndex = 0 To UBound(OrtDat()) - 1
DateiName = Dir("G:\SSM\" & OrtDat(OrdIndex) & "\Kundenlisten\" & "*.xlsm")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:="G:\SSM\" & OrtDat(OrdIndex) & "\Kundenlisten\" & DateiName
For Each Zelle In Worksheets(1).Rows("1:2")
If Zelle.MergeCells Then Zelle.MergeCells = False
Next Zelle
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets("Gesamt").Range("A" & ThisWorkbook.Worksheets("Gesamt").Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
ThisWorkbook.Worksheets(OrtDat(OrdIndex)).Range("A" & ThisWorkbook.Worksheets(OrtDat(OrdIndex)).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Close SaveChanges:=True
End If
DateiName = Dir
Loop
Next OrdIndex
Call EventsOn
End Sub

Answer 7

hi all ^^

*ich hasse verbundene zellen*
*geht zur Entspannung in eine bar*
http://www.youtube.com/watch?v=BZu69_ouc-U

gruss nighty

Answer 8

hi Michael ^^

war schneller zurueck als ich dachte :-)
1)ordne abfrage geaendert
2)der gesammte genutzte Bereich(1 Worksheet) wird auf verbundene zellen geprueft und bei fund geloest

nochmal allre module
probier mal

oder aber es wird ab der 3 zeile erst kopiert wenn die verbundenen Bereiche zeile 1 + 2 snd und die Daten erst ab der 3 zeile kommen ?

gruss nighty

Sub WorksheetCopyWerte()
Call EventsOff
Dim DateiName As String, OrdName As String
Dim OrdIndex As Integer
Dim Zelle As Range
ReDim OrtDat(OrdIndex) As String
OrdName = Dir("G:\SSM\", 16)
Do While OrdName <> ""
If Mid(OrdName, 1, 7) = "Bereich" And OrdExists("G:\SSM\" & OrdName) = True Then
OrtDat(OrdIndex) = OrdName
OrdIndex = OrdIndex + 1
ReDim Preserve OrtDat(OrdIndex)
End If
OrdName = Dir(, 16)
Loop
For OrdIndex = 0 To UBound(OrtDat()) - 1
DateiName = Dir("G:\SSM\" & OrtDat(OrdIndex) & "\Kundenlisten\" & "*.xlsm")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:="G:\SSM\" & OrtDat(OrdIndex) & "\Kundenlisten\" & DateiName
For Each Zelle In Worksheets(1).UsedRange
If Zelle.MergeCells Then Zelle.MergeCells = False
Next Zelle
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets("Gesamt").Range("A" & ThisWorkbook.Worksheets("Gesamt").Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
ThisWorkbook.Worksheets(OrtDat(OrdIndex)).Range("A" & ThisWorkbook.Worksheets(OrtDat(OrdIndex)).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Close SaveChanges:=True
End If
DateiName = Dir
Loop
Next OrdIndex
Call EventsOn
End Sub

Public Function OrdExists(strName As String) As Boolean
On Error Resume Next
ChDir (strName)
If Err = 0 Then OrdExists = True
End Function

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 9

hi all ^^

noch ein wenig optimiert

gruss nighty

Sub WorksheetCopyWerte()
Call EventsOff
Dim DateiName As String, OrdName As String, Quellpfad As String, Anhangpfad As String
Dim OrdIndex As Integer
Dim Zelle As Range
ReDim OrtDat(OrdIndex) As String
Quellpfad = "G:\SSM\"
Anhangpfad = "\Kundenlisten\"
OrdName = Dir(Quellpfad, 16)
Do While OrdName <> ""
If Mid(OrdName, 1, 7) = "Bereich" And GetAttr(Quellpfad & OrdName) = 16 Then
OrtDat(OrdIndex) = OrdName
OrdIndex = OrdIndex + 1
ReDim Preserve OrtDat(OrdIndex)
End If
OrdName = Dir(, 16)
Loop
For OrdIndex = 0 To UBound(OrtDat()) - 1
DateiName = Dir(Quellpfad & OrtDat(OrdIndex) & Anhangpfad & "*.xls")
Do While DateiName <> ""
If ThisWorkbook.Name <> DateiName Then
Workbooks.Open Filename:=Quellpfad & OrtDat(OrdIndex) & Anhangpfad & DateiName
For Each Zelle In Worksheets(1).UsedRange
If Zelle.MergeCells Then Zelle.MergeCells = False
Next Zelle
Workbooks(DateiName).Worksheets(1).Range("A2:Z" & Workbooks(DateiName).Worksheets(1).Range("A" & Rows.Count).End(xlUp).Row).Copy
ThisWorkbook.Worksheets("Gesamt").Range("A" & ThisWorkbook.Worksheets("Gesamt").Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
ThisWorkbook.Worksheets(OrtDat(OrdIndex)).Range("A" & ThisWorkbook.Worksheets(OrtDat(OrdIndex)).Range("A" & Rows.Count).End(xlUp).Row + 1).PasteSpecial Paste:=xlValues, Operation:=xlNone
Workbooks(DateiName).Close SaveChanges:=False
End If
DateiName = Dir
Loop
Next OrdIndex
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 10

Hallo Nighty,

danke für die Ergänzungen!

Ich habe wieder die gleiche Fehlermeldung:
"Laufzeitfehler 9. Index außerhalb des gültigen Bereichs."

Ich klicke auf OK und bin dann in der ersten Quelldatei (wurde durch das Makro geöffnet).
Es sind die Zeilen 2 und 3 der Überschrift markiert und die Zellen mit Einträgen.
Die erste Zeile ist nicht markiert.


In den Quelldateien befindet sich bereits folgendes Makro (damit ich die Filter trotz Blattschutz nutzen kann):

Sub Workbook_Open()
'für alle Blätter mit Passwortschutz
Dim ws As Worksheet
For Each ws In Worksheets
ws.Protect userinterfaceonly:=True, Password:="Beispiel" 'Passwort anpassen
ws.EnableAutoFilter = True 'ermöglicht Autofilter
ws.EnableOutlining = True 'ermöglicht Gruppierung/Gliederung
Next ws
End Sub

Kann das Ursache des Problems sein?


Besten Dank für Deine Mühe!

Michael