mehrere Excel-Dateien auswerten & Werte

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
in meiner Beispieldatei habe ich oben ein Beispiel einer Quelldatei für das erste Quartal aufgeführt.
Im unteren Bereich meiner Beispieldatei habe ich aufgeführt, wie meine Zieldatei am Ende aussehen soll.
Die Daten für die Zieldatei, z. B. für die Zellen C22:C34 kommen aus einer Quelldatei zum ersten Quartal (Zelle D5:D16).
Die Daten für die Zieldatei in D22:D34 kommen dann aus einer anderen Quelldatei zum zweiten Quartal (Zelle D5:D16).
Die Daten für die Zieldatei in E22:E34 kommen dann aus einer dritten Quelldatei zum dritten Quartal (Zelle D5:D16).
Und die Daten für die Zieldatei in F22:F34 kommen aus der Quelldatei zum vierten Quartal (Zelle D5:D16).
Die jeweils benötigte Spalte würde ich gern abgefragt bekommen, wie auch die Abfrage, welche Quelldateien ich verwenden möchte, also ähnlich wie in dem VBA-Code aus dem anderen thread. Die benötigte Spalte aus der Quelldatei ist daher immer eine andere.
Vorgehensweise aktuell:
- Ich kopiere mir die Spalten A:C in meine Zieldatei,
- öffne dann zu Standort A eine Quartalsauswertung für das erste Quartal (Quelldatei1)
- kopiere mir hier die nun benötigte Spalte zur Zuständigkeit 1 (Spalte E) heraus,
- füge diese in meine Zieldatei unter Spalte D ein,
- öffne dann zu diesem Standort A die Quelldatei2, also das zweite Quartal,
- kopiere mir dort die benötigte Spalte zur Zuständigkeit 1 (Spalte E) heraus,
- füge diese in meine Zieldatei unter Spalte E ein,
- öffne die Quelldatei3 zum Standort A für das dritte Quartal,
- kopiere mir dort die benötigte Spalte zur Zuständigkeit 1 (Spalte E) heraus,
- füge diese in meine Zieldatei unter Spalte F ein,
- öffne die Quelldatei 4 zum Standort A für das vierte Quartal,
- kopiere mir die Zuständigkeit 1 (Spalte E) heraus,
- füge diese in meine Zieldatei unter Spalte G ein und
- füge zum Schluss noch eine weitere Spalte für die Jahresübersicht mit den entsprechenden Formeln ein.
Dies wiederhole ich, bis ich alle Zuständigkeiten aus dem Standort A in jeweils einer Zieldatei zusammengeführt habe.
D.h. ich nehme für meine nächste Zieldatei ebenfalls den Standort A, diesmal aber die Zuständigkeit 2, also Spalte F.
Und das ganze Prozedere dann noch für alle übrigen knapp 100 Standorte.
Ich hoffe, ich konnte das Dilemma etwas verdeutlichen.
Lieb wäre mir, wenn ich zumindest über einen VBA-Code die Quell-Dateien auswählen kann und die Quell-Spalte abgefragt bekomme und diese dann für alle vier Quartale zu einer Zieldatei zusammengeführt wird. Vielleicht geht das ja auch alles noch viel schicker. Ich wäre aber durchaus auch schon damit zufrieden.
Könnt Ihr mir bitte helfen?
LG
RohDiamant

'Code in einem allgemeinen Modul Sub Daten_einlesen() Dim wkbQuelle As Workbook Dim wksQuelle As Worksheet Dim wksZiel As Worksheet Dim varFiles As Variant Dim varDatei As Variant Dim StatusCalc As Long Dim Sp As Range 'Dateiauswahl varFiles = Array() With Application.FileDialog(msoFileDialogOpen) .Title = "Bitte auszuwertende Dateien auswählen - Mehrfachauswahl ist möglich" .AllowMultiSelect = True If .Show = -1 Then Set varFiles = .SelectedItems End With If UBound(varFiles) = -1 Then MsgBox "Kein Datei ausgewählt", vbInformation, "Abbruch" Exit Sub End If 'Makrobremsen lösen With Application StatusCalc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'gewählte Dateien abarbeiten For Each varDatei In varFiles Set wkbQuelle = Application.Workbooks.Open(Filename:=varDatei, ReadOnly:=True) Set wksQuelle = wkbQuelle.Sheets(1) 'Gegenstand lesen For Each Sp In wksQuelle.Range("C7:K7").Cells 'anpassen: bis wo gibt es "Gegenstände"? 'Gegenstand lesen, Worksheet selektieren oder erzeugen Set wksZiel = Worksheet_auswählen(wksQuelle.Range(Sp.Value)) 'bei neues Blatt If wkszeile.Range("A7") = "" Then wksZiel.Range("A7:B16") = wksQuelle.Range("A7:B16").Value 'Zeilenüberschriften wksZiel.Range("C4:G4") = Array("Quartal 1", "Quartal 2", "Quartal 3", "Quartal 4", "Jahresergebnis zu") wksZiel.Range("G7:G16").Formula = "=F7" 'Werte Quartal 4., per Default zuerst überall wksZiel.Range("G11:G13, G16").FormulaLocal = "SUMME(C11:F11)" 'Summierbare Werte (Bewegung) wksZiel.Range("G9:G10").Formula = "=C7" 'Werte Q1 End If Quartal = CLng(Right(wksQuelle.Range("B5"), 1)) 'QuartalNr isolieren wksZiel.Range("B7.B16").Offset(0, Quartal).Value = Intersect(wksQuelle.Rows("5:16"), Sp.EntireColumn).Value 'Werte übertragen Next wkbQuelle.Close savechanges:=False Next 'Makrobremsen zurücksetzen With Application .Calculation = StatusCalc .ScreenUpdating = True .EnableEvents = True End With End Sub Private Function Worksheet_auswählen(WsName As String) As Worksheet Dim W As Worksheet On Error Resume Next Set W = ThisWorkbook.Worksheets(WsName) If Worksheet_auswählen Is Nothing Then Set W = ThisWorkbook.Worksheets.Add W.Name = WsName End If Set Worksheet_auswählen = W End Function

'Code in einem allgemeinen Modul Sub Daten_einlesen() Dim FD As FileDialog Dim wkbQuelle As Workbook Dim wksQuelle As Worksheet Dim wksZiel As Worksheet Dim DateiPfad As Variant Dim StatusCalc As Long Dim Sp As Range 'Dateiauswahl Set FD = Application.FileDialog(msoFileDialogOpen) FD.Title = "Bitte auszuwertende Dateien auswählen - Mehrfachauswahl ist möglich" FD.AllowMultiSelect = True FD.Show 'Makrobremsen lösen With Application StatusCalc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'gewählte Dateien abarbeiten For Each DateiPfad In FD.SelectedItems Set wkbQuelle = Application.Workbooks.Open(Filename:=DateiPfad, ReadOnly:=True) Set wksQuelle = wkbQuelle.Sheets(1) 'Gegenstand lesen For Each Sp In wksQuelle.Range("C7:K7").Cells 'anpassen: bis wo gibt es "Gegenstände"? 'Gegenstand lesen, Worksheet selektieren oder erzeugen Set wksZiel = Worksheet_auswählen(wksQuelle.Range(Sp.Value)) 'bei neues Blatt If wkszeile.Range("A7") = "" Then wksZiel.Range("A7:B16") = wksQuelle.Range("A7:B16").Value 'Zeilenüberschriften wksZiel.Range("C4:G4") = Array("Quartal 1", "Quartal 2", "Quartal 3", "Quartal 4", "Jahresergebnis zu") wksZiel.Range("G7:G16").Formula = "=F7" 'Werte Quartal 4., per Default zuerst überall wksZiel.Range("G11:G13, G16").FormulaLocal = "SUMME(C11:F11)" 'Summierbare Werte (Bewegung) wksZiel.Range("G9:G10").Formula = "=C9" 'Werte Q1 End If Quartal = CLng(Right(wksQuelle.Range("B5"), 1)) 'QuartalNr isolieren wksZiel.Range("B7:B16").Offset(0, Quartal).Value = Intersect(wksQuelle.Rows("5:16"), Sp.EntireColumn).Value 'Werte übertragen Next wkbQuelle.Close savechanges:=False Next 'Makrobremsen zurücksetzen With Application .Calculation = StatusCalc .ScreenUpdating = True .EnableEvents = True End With End Sub Private Function Worksheet_auswählen(WsName As String) As Worksheet Dim W As Worksheet On Error Resume Next Set W = ThisWorkbook.Worksheets(WsName) If W Is Nothing Then Set W = ThisWorkbook.Worksheets.Add W.Name = WsName End If Set Worksheet_auswählen = W End Function

'Gegenstand lesen For Each Sp In wksQuelle.Range("C7:K7").Cells 'anpassen: bis wo gibt es "Gegenstände"? If Sp.Value = "" Then Exit For 'Gegenstand lesen, Worksheet selektieren oder erzeugen Set wksZiel = Worksheet_auswählen(Sp.Value) 'bei neues Blatt

'Code in einem allgemeinen Modul Sub Daten_einlesen() Dim FD As FileDialog Dim wkbQuelle As Workbook Dim wksQuelle As Worksheet Dim wksZiel As Worksheet Dim DateiPfad As Variant Dim StatusCalc As Long Dim Sp As Range 'Dateiauswahl Set FD = Application.FileDialog(msoFileDialogOpen) FD.Title = "Bitte auszuwertende Dateien auswählen - Mehrfachauswahl ist möglich" FD.AllowMultiSelect = True FD.Show 'Makrobremsen lösen With Application StatusCalc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'gewählte Dateien abarbeiten For Each DateiPfad In FD.SelectedItems Set wkbQuelle = Application.Workbooks.Open(Filename:=DateiPfad, ReadOnly:=True) Set wksQuelle = wkbQuelle.Sheets(1) 'Gegenstand lesen For Each Sp In wksQuelle.Range("C7:K7").Cells 'anpassen: bis wo gibt es "Gegenstände"? If Sp.Value = "" Then Exit For 'Gegenstand lesen, Worksheet selektieren oder erzeugen Set wksZiel = Worksheet_auswählen(Sp.Value) 'bei neues Blatt If wksZiel.Range("A7") = "" Then wksZiel.Range("A7:B16") = wksQuelle.Range("A7:B16").Value 'Zeilenüberschriften wksZiel.Range("C4:G4") = Array("Quartal 1", "Quartal 2", "Quartal 3", "Quartal 4", "Jahresergebnis zu") wksZiel.Range("G7:G16").Formula = "=F7" 'Werte Quartal 4., per Default zuerst überall wksZiel.Range("G11:G13, G16").FormulaLocal = "SUMME(C11:F11)" 'Summierbare Werte (Bewegung) wksZiel.Range("G9:G10").Formula = "=C9" 'Werte Q1 End If Quartal = CLng(Right(wksQuelle.Range("B5"), 1)) 'QuartalNr isolieren wksZiel.Range("B7:B16").Offset(0, Quartal).Value = Intersect(wksQuelle.Rows("5:16"), Sp.EntireColumn).Value 'Werte übertragen Next wkbQuelle.Close savechanges:=False Next 'Makrobremsen zurücksetzen With Application .Calculation = StatusCalc .ScreenUpdating = True .EnableEvents = True End With End Sub Private Function Worksheet_auswählen(WsName As String) As Worksheet Dim W As Worksheet On Error Resume Next Set W = ThisWorkbook.Worksheets(WsName) If W Is Nothing Then Set W = ThisWorkbook.Worksheets.Add W.Name = WsName End If Set Worksheet_auswählen = W End Function

Hallo Yal,
ich habe mir die Nacht um die Ohren geschlagen und einiges ausprobiert, bisher leider ohne Erfolg.
Ich habe testweise in Zelle B5 der Quelldatei jeweils "Quartal 1", "Quartal 2", "Quartal 3", "Quartal 4" geschrieben und bekomme dann zumindest auch alle Quartale eingelesen. Leider werden hierbei allerdings die Werte aus den Quelldateien in den Zielbereich F5:F18 geschrieben, obwohl das Ziel mit E5:E18 definiert ist.
Hier mal der angepasste Code:


'Code in einem allgemeinen Modul
Sub Daten_einlesen()
Dim FD As FileDialog
Dim wkbQuelle As Workbook
Dim wksQuelle As Worksheet
Dim wksZiel As Worksheet
Dim DateiPfad As Variant
Dim StatusCalc As Long
Dim Sp As Range
'Dateiauswahl
Set FD = Application.FileDialog(msoFileDialogOpen)
FD.Title = "Bitte auszuwertende Dateien auswählen - Mehrfachauswahl ist möglich"
FD.AllowMultiSelect = True
FD.Show
'Makrobremsen lösen
With Application
StatusCalc = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
.EnableEvents = False
End With
'gewählte Dateien abarbeiten
For Each DateiPfad In FD.SelectedItems
Set wkbQuelle = Application.Workbooks.Open(Filename:=DateiPfad, ReadOnly:=True)
Set wksQuelle = wkbQuelle.Sheets(1)
'Gegenstand lesen
For Each Sp In wksQuelle.Range("E7:BZ7").Cells 'anpassen: bis wo gibt es "Zuständigkeiten"?
If Sp.Value = "" Then Exit For
'Gegenstand lesen, Worksheet selektieren oder erzeugen
Set wksZiel = Worksheet_auswählen(Sp.Value)
'in Jahresübersicht (neues Blatt)
'Wenn Zielzelle A7 leer, dann
If wksZiel.Range("A7") = "" Then
'setze in Tabellenblatt der Zieldatei im Bereich A7:C18 die Werte aus dem Tabellenblatt der Quelldatei im Bereich A7:C18
wksZiel.Range("A7:C18") = wksQuelle.Range("A7:C18").Value 'Zeilenüberschriften
'setze Spaltenüberschriften in Zeile 4 der Zieldatei
wksZiel.Range("D4:H4") = Array("Jahresergebnis zu", "Quartal 1", "Quartal 2", "Quartal 3", "Quartal 4") 'Spaltenüberschriften
'setze in der Spalte Jahresergebnis der Zieldatei die Formeln
wksZiel.Range("D9:D18").Formula = "=H9" 'Werte Quartal 4., per Default zuerst überall
wksZiel.Range("D11:D13, D16:D18").FormulaLocal = "=SUMME(E11:H11)" 'Summierbare Werte (Bewegung)
wksZiel.Range("D9:D10").Formula = "=E9" 'Werte Quartal 1
End If
Quartal = CLng(Right(wksQuelle.Range("B5"), 1)) 'QuartalNr isolieren
wksZiel.Range("E5:E18").Offset(0, Quartal).Value = Intersect(wksQuelle.Rows("5:18"), Sp.EntireColumn).Value 'Werte übertragen
Next
wkbQuelle.Close savechanges:=False
Next
'Makrobremsen zurücksetzen
With Application
.Calculation = StatusCalc
.ScreenUpdating = True
.EnableEvents = True
End With
'Zieltabelle formatieren
With wksZiel
.Columns.AutoFit
End With
End Sub
Private Function Worksheet_auswählen(WsName As String) As Worksheet
Dim W As Worksheet
On Error Resume Next
Set W = ThisWorkbook.Worksheets(WsName)
If W Is Nothing Then
Set W = ThisWorkbook.Worksheets.Add
W.Name = WsName
End If
Set Worksheet_auswählen = W
End Function

und die beigefügte Jahresübersicht "2021_Jahresübersicht_Standort_A_Test2.xlsx" (https://www.herber.de/bbs/user/151892.xlsx).
Ich finde einfach meinen Fehler nicht. Die Zeile


wksZiel.Range("E5:E18").Offset(0, Quartal).Value = Intersect(wksQuelle.Rows("5:18"), Sp.EntireColumn).Value 'Werte übertragen

enthält den Zielbereich E5:E18, weshalb wird dann das Quartal 1 nicht in Spalte E, sondern in Spalte F unter Quartal 2 eingefügt und auch die weiteren Quartale verschoben?
Auch unter den Spaltenüberschriften kann ich keinen Fehler entdecken:


wksZiel.Range("D4:H4") = Array("Jahresergebnis zu", "Quartal 1", "Quartal 2", "Quartal 3", "Quartal 4") 'Spaltenüberschriften

Dann habe ich mir überlegt, wie man im Bereich "QuartalNr isolieren" das Quartal ermitteln könnte.

Könnte man


Quartal = CLng(Right(wksQuelle.Range("B5"), 1)) 'QuartalNr isolieren

das Quartal aus E1 ermitteln? Z. B. Wenn die Zelle E1 "01.01." enthält, dann ist das Quartal 1, wenn die Zelle E1 "01.04." enthält, ist das Quartal 2, wenn die Zelle E1 "01.07." enthält, dann ist das Quartal 3 und wenn die Zelle E1 "01.10." enthält, dann ist das Quartal 4.

Oder könnte man das Quartal aus dem Dateinamen auslesen? Jede Quelldatei enthält eine römische Ziffer im Dateinamen, wie z. B. "2021_I_20210101_20210331_Standort_A.xlsx" (I = Quartal 1). Der Dateiname der Quelldateien ist also immer wie folgt aufgebaut: "JJJJ_Q_Zeitraum_Standort.xlsx" (Q = Quartal).

Weiterhin habe ich einen Bereich "'Zieltabelle formatieren" für die Formatierung hinzugefügt. Leider wird diese Formatierung lediglich im zuletzt erstellten Tabellenblatt vorgenommen. Die vorigen Tabellenblätter der Zieldatei werden nicht formatiert.
Und nun noch eine "letzte" Frage: Könnte man die Tabellenblätter in umgekehrter Reihenfolge einfügen?
Momentan wird die letzte Zuständigkeit (z. B. 13) als erstes Tabellenblatt ganz links und die erste Zuständigkeit (z. B. 1) als letztes Tabellenblatt ganz rechts eingefügt.
Könnte man die erste Zuständigkeit (z. B. 1) als erstes Tabellenblatt ganz links und die letzte Zuständigkeit (z. B. 13) als letztes Tabellenblatt ganz rechts einfügen?
LG
RohDiamant

'Code in einem allgemeinen Modul Sub Daten_einlesen() Dim FD As FileDialog Dim StatusCalc As Long Dim wkbQuelle As Workbook Dim wksQuelle As Worksheet Dim wksZiel As Worksheet Dim Sp As Range 'Dateiauswahl Set FD = Application.FileDialog(msoFileDialogOpen) FD.Title = "Bitte auszuwertende Dateien auswählen - Mehrfachauswahl ist möglich" FD.AllowMultiSelect = True FD.Show 'Makrobremsen lösen With Application StatusCalc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'gewählte Dateien abarbeiten For Each DateiPfad In FD.SelectedItems Set wkbQuelle = Application.Workbooks.Open(Filename:=DateiPfad, ReadOnly:=True) Set wksQuelle = wkbQuelle.Sheets(1) 'Datum im Quelle lesen, daraus Quartal ableiten Quartal = Month(CDate(Trim(Split(wksQuelle.Range("E1").Value, "-")(1)))) / 3 'QuartalNr isolieren 'Gegenstand lesen For Each Sp In wksQuelle.Range("E7:BZ7").Cells 'anpassen: bis wo gibt es "Zuständigkeiten"? If Sp.Value = "" Then Exit For 'Falls der gegebene Bereich der ÜPebrschrift zu grosszügig festgelegt wurde 'Gegenstand lesen, Worksheet selektieren oder erzeugen Set wksZiel = Worksheet_auswählen(Sp.Value, wksQuelle) 'Werte ans Ziel schrieben, Spalten F, G, H, I wksZiel.Range("E5:E18").Offset(0, Quartal).Value = Intersect(wksQuelle.Rows("5:18"), Sp.EntireColumn).Value 'Werte übertragen Next wkbQuelle.Close savechanges:=False Next 'Makrobremsen zurücksetzen With Application .Calculation = StatusCalc .ScreenUpdating = True .EnableEvents = True End With 'Zieltabelle formatieren With wksZiel .Columns.AutoFit End With End Sub Private Function Worksheet_auswählen(WsName As String, Optional wsQ As Worksheet) As Worksheet Dim W As Worksheet On Error Resume Next Set W = ThisWorkbook.Worksheets(WsName) If W Is Nothing Then Set W = ThisWorkbook.Worksheets.Add W.Name = WsName W.Range("A7:C18") = wsQ.Range("A7:C18").Value 'Zeilenüberschriften W.Range("D4:H4") = Array("Quartal 1", "Quartal 2", "Quartal 3", "Quartal 4", "Jahresergebnis zu") W.Range("D7:D18").Formula = "=H7" 'Werte Quartal 4., per Default zuerst überall W.Range("D11:D13, D16:D18").FormulaLocal = "=SUMME(E11:H11)" 'Summierbare Werte (Bewegung) W.Range("D9:D10").Formula = "=E9" 'Werte Quartal 1 End If Set Worksheet_auswählen = W End Function

'Code in einem allgemeinen Modul Sub Daten_einlesen() Dim FD As FileDialog Dim StatusCalc As Long Dim wkbQuelle As Workbook Dim wksQuelle As Worksheet Dim wksZiel As Worksheet Dim Sp As Range 'Dateiauswahl Set FD = Application.FileDialog(msoFileDialogOpen) FD.Title = "Bitte auszuwertende Dateien auswählen - Mehrfachauswahl ist möglich" FD.AllowMultiSelect = True FD.Show 'Makrobremsen lösen With Application StatusCalc = .Calculation .Calculation = xlCalculationManual .ScreenUpdating = False .EnableEvents = False End With 'gewählte Dateien abarbeiten For Each DateiPfad In FD.SelectedItems Set wkbQuelle = Application.Workbooks.Open(Filename:=DateiPfad, ReadOnly:=True) Set wksQuelle = wkbQuelle.Sheets(1) 'Datum in Quelle lesen, daraus Quartal ableiten Quartal = Month(CDate(Trim(Split(wksQuelle.Range("E1").Value, "-")(1)))) / 3 'QuartalNr isolieren 'Gegenstand lesen For Each Sp In wksQuelle.Range("E7:BZ7").Cells 'anpassen: bis wo gibt es "Zuständigkeiten"? If Sp.Value = "" Then Exit For 'Falls der gegebene Bereich der Überschrift (Spalten) zu grosszügig festgelegt wurde 'Gegenstand lesen, Worksheet selektieren oder erzeugen Set wksZiel = Worksheet_auswählen(Sp.Value, wksQuelle) 'Werte ans Ziel schreiben, Spalten E, F, G, H wksZiel.Range("D5:D417").Offset(0, Quartal).Value = Intersect(wksQuelle.Rows("5:417"), Sp.EntireColumn).Value 'Werte übertragen 'Zieltabelle formatieren With wksZiel .Columns.AutoFit End With Next wkbQuelle.Close savechanges:=False Next 'Makrobremsen zurücksetzen With Application .Calculation = StatusCalc .ScreenUpdating = True .EnableEvents = True End With End Sub Private Function Worksheet_auswählen(WsName As String, Optional wsQ As Worksheet) As Worksheet Dim W As Worksheet On Error Resume Next Set W = ThisWorkbook.Worksheets(WsName) If W Is Nothing Then Set W = ThisWorkbook.Worksheets.Add W.Name = WsName W.Range("A7:C417") = wsQ.Range("A7:C417").Value 'Zeilenüberschriften W.Range("D4:H4") = Array("Jahresergebnis zu", "Quartal 1", "Quartal 2", "Quartal 3", "Quartal 4") 'Spaltenüberschriften W.Range("D7:D417").Formula = "=H7" 'Werte Quartal 4., per Default zuerst überall W.Range("D11:D13, D16:D417").FormulaLocal = "=SUMME(E11:H11)" 'Summierbare Werte (Bewegung) W.Range("D9:D10").Formula = "=E9" 'Werte Quartal 1 End If End If Set Worksheet_auswählen = W End Function

Beliebteste Forumthreads (12 Monate)

mehrere Excel-Dateien auswerten & Werte

26 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

26
Beiträge zum Forumthread

Beiträge zu diesem Forumthread