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

blattschutz ?

bei mehreren auszulesenden Mappen musst du dann alle passwoerter kennen ?
oder ist es immer das gleiche ?

gruss nighty

Answer 2

hi michael ^^

probier mal

gruss nighty

dein Passwort noch einsetzen
anstatt "DeinPasswort"

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
Workbooks(DateiName).Worksheets(1).Unprotect ("DeinPasswort")
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

Answer 3

Hallo Nighty,

die Zellen sind wie folgt verbunden:

A1,A2
B1,B2
C1,C2
D1,D2
E1,E2
F1,F2
G1,G2
H1,H2
I1,I2
J1,J2
K1,K2
L1,L2
M1,M2
N1,N2
O1,O2
P1 bis V1 (alle verbunden)
W1,W2
X1,X2
Y1,Y2

Besten Dank für Deine Mühe!

Michael

Answer 4

hi Michael ^^

es werden alle verbundenen zellen gelöst im Bereich a1 bis z Zeilenende

dann lade eine dummy Datei hoch,fileupload oder aehnliche nutzen

gruss nighty

Answer 5

Hallo Nighty,

die Zellen sind wie folgt verbunden:

A1 mit A2, B1 mit B2 usw. bis O1 mit O2.

Die Zellen P1, Q1, R1, S1, T1, U1 und V1 sind verbunden (also P1 bis V1 ein Verbund).
Die Zellen P2 bis V2 sind nicht verbunden.

Dann wieder W1 mit W2, X1 mit X2, Y1 mit Y2 und Z1 mit Z2.


Besten Dank für Deine Mühe!

Michael

Answer 6

hi all ^^

wo die Bereiche liegen ist erstmal nicht wichtig ,da ein Automatismus alle verbaende loest

es wird also an deinem blattschutz liegen(vermutung)

da wir im halbdunkel rumtapsen,die Aufforderung zur dummydatei im xls Format bitte(eine auszulesende datei)

gruss nighty

Answer 7

Hallo zusammen,

leider funktioniert es noch nicht richtig.
Kann jemand helfen?

Danke vorab und beste Grüße

Michael