Daten aus mehreren Excel Arbeitsmappen mit mehreren Tabellenblätter zusammenführen

Question

Hallo,
mein Problem ist folgendes:

In dem Verzeichnis C:\Daten befinden sich mehrere Excel (2010) Arbeitsmappen, die nach ihrem Erstellungsdatum (KW1, KW2,....KWX) benannt sind. Jede Arbeitsmappe ist in der Struktur identisch: Jede Arbeitsmappe enthält 23 Tabellenblätter, die in jeder Mappe gleich benannt und aufgebaut sind, nur die eingegebenen Daten unterscheiden sich.

Jede Woche im Laufe des Jahres kommt eine neue Datei hinzu. Somit ist die Anzahl an Dateien im Verzeichnis variabel, wenn aber auf 53 begrenzt.

Für meine Auswertung benötige aus jeder Arbeitsmappe, die sich zum Zeitpunkt der Auswertung in dem Verzeichnis befindet, nur die Daten aus den Tabellenblättern 21 und 22.

Aus den Tabellenblättern 21 jeder Arbeitsmappe sollen nur die Daten aus dem Bereich E2:F2 zusammengeführt und in ein Tabellenblatt (Daten1) einer bestehende Arbeitsmappe (Analyse.xlsx) in ein anderes Verzeichnis (F:\ Auswertung) kopiert werden. Der Einfügebereich beginnt bei B2, da die Zeilen- und Spaltenüberschriften vorgegeben sind. Die Daten aus E2:F2 sind formelbasierte Berechnungen, ich benötige nur die Werte.

Aus den Tabellenblättern 22 sollen die Daten aus dem Bereich A2:M2 zusammengeführt und in das Tabellenblatt Daten2 (Verzeichnis F:\Auswertung, Arbeitsmappe Analyse.xlsx) kopiert werden. Der Einfügebereich beginnt auch hier bei B2.

Auf beiden Tabellenblättern (21&22) der Quelldateien liegt ein Blattschutz, der nicht kennwortgeschützt ist.

Ich denke, dass hier eine Lösung über VBA erforderlich ist, jedoch sind meine VBA-Kenntnisse sehr begrenzt.

Für eure Hilfe wäre ich sehr dankbar!

Answer 1

hi ^^

noch ohne schutz aufloesung

schau mak drueber ob es ok ist ,quellen und ziele

schutz aufloesung kommt noch

war jetzt auf die schnelle

gruss nighty

Sub DateienLesen()
Call EventsOff
Dim DateiName As String
DateiName = Dir("C:\Daten\" & "*.xls")
Workbooks.Open Filename:="F:\Auswertung\Analyse"
Do While DateiName <> ""
Workbooks.Open Filename:="C:\Daten\" & DateiName
Workbooks(DateiName).Worksheets("21").Range("E2:F2").Copy _
Workbooks("Analyse").Worksheets("Daten1").Range("B" & Workbooks("Analyse").Worksheets("Daten1").Cells(Rows.Count, 2).End(xlUp).Row) + 1
Workbooks(DateiName).Worksheets("21").Range("A2:M2").Copy _
Workbooks("Analyse").Worksheets("Daten1").Range("B" & Workbooks("Analyse").Worksheets("Daten1").Cells(Rows.Count, 2).End(xlUp).Row) + 1
Workbooks(DateiName).Close
DateiName = Dir
Loop
Workbooks.Save Filename:="F:\Auswertung\Analyse"
Workbooks("Analyse").Close
Call EventsOn
End Sub

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

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

Answer 2

Wow, vielen Dank!

Das ging ja flott! Ich werde es heute noch ausprobieren.
Einen kleinen Fehler hab ich zwar schon gefunden, aber das ist nicht so wild. Der zweite Copy Befehl erfolgt aus Tabelle 22 und soll in die Tabelle Daten2 eingefügt werden.

Answer 3

hi all ^^

vielleicht so :-)

gruss nighty

Sub DateienLesen()
Call EventsOff
Dim DateiName As String
Workbooks.Open Filename:="F:\Auswertung\Analyse", FileFormat:=xlNormal, Password:="", WriteResPassword:=""
DateiName = Dir("C:\Daten\" & "*.xls")
Do While DateiName <> ""
Workbooks.Open Filename:="C:\Daten\" & DateiName, FileFormat:=xlNormal, Password:="", WriteResPassword:=""
Workbooks(DateiName).Worksheets("21").Range("E2:F2").Copy _
Workbooks("Analyse").Worksheets("Daten1").Range("B" & Workbooks("Analyse").Worksheets("Daten1").Cells(Rows.Count, 2).End(xlUp).Row) + 1
Workbooks(DateiName).Worksheets("21").Range("A2:M2").Copy _
Workbooks("Analyse").Worksheets("Daten1").Range("B" & Workbooks("Analyse").Worksheets("Daten1").Cells(Rows.Count, 2).End(xlUp).Row) + 1
Workbooks(DateiName).Close
DateiName = Dir
Loop
Workbooks("Analyse").SaveAs Filename:="F:\Auswertung\Analyse", FileFormat:=xlNormal, Password:="", WriteResPassword:=""
Workbooks("Analyse").Close
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 4

hi all ^^

ops daten1 noch korrigieren ^^

gruss nighty

Answer 5

hi all^^

oder hast du noch

arbeitsmappe geschützt ?
und/oder
worksheets geschützt ?

gruss nighty

Answer 6

hi all ^^

dann so vielleicht :-)

gruss nighty

Sub DateienLesen()
Call EventsOff
Dim DateiName As String
Workbooks.Open Filename:="F:\Auswertung\Analyse", FileFormat:=xlNormal, Password:="", WriteResPassword:=""
Workbooks("Analyse").Unprotect
Worksheets("Daten1").Unprotect
Worksheets("Daten2").Unprotect
DateiName = Dir("C:\Daten\" & "*.xls")
Do While DateiName <> ""
Workbooks.Open Filename:="C:\Daten\" & DateiName, FileFormat:=xlNormal, Password:="", WriteResPassword:=""
Workbooks(DateiName).Unprotect
Worksheets("21").Unprotect
Worksheets("22").Unprotect
Workbooks(DateiName).Worksheets("21").Range("E2:F2").Copy _
Workbooks("Analyse").Worksheets("Daten1").Range("B" & Workbooks("Analyse").Worksheets("Daten1").Cells(Rows.Count, 2).End(xlUp).Row) + 1
Workbooks(DateiName).Worksheets("21").Range("A2:M2").Copy _
Workbooks("Analyse").Worksheets("Daten2").Range("B" & Workbooks("Analyse").Worksheets("Daten2").Cells(Rows.Count, 2).End(xlUp).Row) + 1
Worksheets("21").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Worksheets("22").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Workbooks(DateiName).Protect Structure:=True, Windows:=True
Workbooks(DateiName).Close
DateiName = Dir
Loop
Workbooks("Analyse").Worksheets("Daten1").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Workbooks("Analyse").Worksheets("Daten2").Protect DrawingObjects:=True, Contents:=True, Scenarios:=True
Workbooks("Analyse").Protect Structure:=True, Windows:=True
Workbooks("Analyse").Workbooks("Analyse").SaveAs Filename:="F:\Auswertung\Analyse", FileFormat:=xlNormal, Password:="", WriteResPassword:=""
Workbooks("Analyse").Close
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 7

hi all ^^

2 zeile des copybefehls noch 22 einsetzen
evenzuell die Endung xls in der 7 zeile noch aendern

makro war nicht getestet

gruss nighty