VBA Excel-Dateien/-blätter zusammenfassen

Hallo zusammen,
seit Tagen versuche ich eine VBA-Lösung bzgl. dieses Themas zu basteln:
Aus ca. 20 unterschiedlichen xls-Dateien mit unterschiedlichen Arbeitsblättern soll eine neue Arbeitsmappe mit nur 1 Tabelle generiert werden (kfm. Bereich - Reportingdateien zum Quartalsende). Die Zielarbeitsmappe dient nur dazu, sich einen Überblick über die Datenlage zu verschaffen.
Die Namen der Quellarbeitsmappen habe ich in einer separaten Arbeitsmappe als "Liste" zusammengefasst mit den Attributen (z.B. Arbeitsmappe1, Arbeitsblatt5, Bereich A2:G15). Die Quelldateien liegen immer im gleichen Verzeichnis. Bei allen Arbeitsblättern ist der zu kopierende Bereich unterschiedlich.
Ein Makro soll anhand der "Liste" die entsprechenden Arbeitsmappen iterativ öffnen, aktualisieren, den o.g. Bereich auswählen + kopieren und in der Zielarbeitsmappe in dem Zielarbeitsblatt wieder einfügen, 1 Zeile Vorschub. Als Überschrift in dem Arbeitsblatt sollte jeweils noch der Dateiname der Quell-Arbeitsmappe erscheinen.
Es gibt hier sehr gute Ansätze (soweit ich das sagen kann), aber das Prozedere über die Liste, die ja dynamisch eingelesen und verarbeitet werden soll, habe ich so leider nicht gefunden bzw. ich stehe mit meinen bescheidenen VBA-Kenntnissen "auf dem Schlauch".
Hat jemand eine gute Idee?
Frohe Festtage,
Harry07

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo Harry,
hier ein Gerüst, um eine Liste von Dateien abzuarbeiten und einen Teil ihrer Daten zu kopieren.
Gruß
Franz

Sub Bereiche_kopieren()
Dim wksListe As Worksheet, ZeileL As Long
Dim wkbZiel As Workbook, wksZiel As Worksheet
Dim wkbQuelle As Workbook, wksQ As Worksheet
Dim sPfad As String, sDatei As String
Dim sMappe As String, sBlatt As String, sBereich As String
Dim ZeileZ  As Long, rngCopy As Range
If MsgBox("Daten laden?", vbQuestion + vbOKCancel, "Daten konsoldieren") _
= vbCancel Then Exit Sub
Application.ScreenUpdating = False
Set wksListe = ActiveWorkbook.Worksheets("Liste")
Set wkbZiel = Application.Workbooks("GetData.xlsm") 'Dateiname anpassen!!
Set wksZiel = wkbZiel.Worksheets("Ziel") 'Blattname anpassen
sPfad = "C:\Users\Public\NeuTest\" 'Verzeichnis mit den Daten-Dateien
ZeileZ = 2 'erste Zeile in der Daten im Zielblatt eingefügt werden sollen
With wksListe
For ZeileL = 2 To .Cells(.Rows.Count, 1).End(xlUp).Row
sMappe = .Cells(ZeileL, 1).Text
sBlatt = .Cells(ZeileL, 2).Text
sBereich = .Cells(ZeileL, 3).Text
sDatei = sPfad & sMappe
If Dir(sDatei, vbNormal)  "" Then
Set wkbQuelle = Application.Workbooks.Open(Filename:=sDatei, _
UpdateLinks:=True, ReadOnly:=True)
If fncCheckSheetName(sSheet:=sBlatt, wkb:=wkbQuelle) = False Then
With wksZiel
.Cells(ZeileZ, 1).Value = sMappe
.Cells(ZeileZ, 4).Value = "Blatt """ & sBlatt & """ nicht vorhanden"
ZeileZ = ZeileZ + 1
End With
Else
Set wksQ = wkbQuelle.Worksheets(sBlatt)
Set rngCopy = wksQ.Range(sBereich)
With wksZiel
.Cells(ZeileZ, 1).Value = sMappe
ZeileZ = ZeileZ + 1
rngCopy.Copy
.Cells(ZeileZ, 1).PasteSpecial Paste:=xlPasteFormats
.Cells(ZeileZ, 1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
ZeileZ = ZeileZ + rngCopy.Rows.Count
Set rngCopy = Nothing
End With
End If
wkbQuelle.Close savechanges:=False
Set wkbQuelle = Nothing
Else
With wksZiel
.Cells(ZeileZ, 1).Value = sMappe
.Cells(ZeileZ, 4).Value = "Datei nicht gefunden"
ZeileZ = ZeileZ + 1
End With
End If
Next ZeileL
End With
Application.ScreenUpdating = True
End Sub
Function fncCheckSheetName(sSheet As String, wkb As Workbook) As Boolean
Dim objSheet As Object
On Error GoTo Fehler
fncCheckSheetName = False
Set objSheet = wkb.Sheets(sSheet)
fncCheckSheetName = True
Fehler:
End Function

' ********************************************************************** ' Modul: Modul2 Typ: Allgemeines Modul ' ********************************************************************** Option Explicit Sub collectData() Dim objWB As Workbook, objSheet As Object Dim varList As Variant, lngIndex As Long, lngRow As Long On Error GoTo ErrorHandler With Application .ScreenUpdating = False .EnableEvents = False .AskToUpdateLinks = False .DisplayAlerts = False .Calculation = xlCalculationManual End With 'Tabelle mit der 'Liste', Dateiname = A2:Ax, Tabelle = B2:Bx, Bereich = C2:Cx - Anpassen! With Sheets("Liste") varList = .Range("A2:C" & Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row)) End With Set objSheet = ThisWorkbook.Worksheets.Add(After:=Sheets(Sheets.Count)) lngRow = 1 With objSheet .Name = "Daten " & Format(Now, "YYMMDD_hhnnss") For lngIndex = 1 To UBound(varList, 1) .Cells(lngRow, 1) = varList(lngIndex, 1) .Rows(lngRow).Font.Bold = True lngRow = lngRow + 1 If Dir(varList(lngIndex, 1), vbNormal) <> "" Then Set objWB = Workbooks.Open(Filename:=varList(lngIndex, 1), UpdateLinks:=True) Application.Calculate objWB.Sheets(varList(lngIndex, 2)).Range(varList(lngIndex, 3)).Copy .Cells(lngRow, 1) objWB.Close True Else .Cells(lngRow, 1) = "Datei nicht gefunden!" End If lngRow = Application.Max(2, .Cells(.Rows.Count, 1).End(xlUp).Row + 2) Next End With ErrorHandler: If Err.Number <> 0 Then MsgBox "Fehler in Modul1" & vbLf & vbLf & "Prozedur:" & vbTab & "collectData" & vbLf & _ "Nummer:" & vbTab & Err.Number & vbLf & "Meldung:" & vbTab & Err.Description & vbLf & _ IIf(Erl, "Zeile:" & vbTab & Erl, ""), vbExclamation, "Fehler!" Err.Clear End If With Application .ScreenUpdating = True .EnableEvents = True .AskToUpdateLinks = True .DisplayAlerts = True .Calculation = xlCalculationAutomatic End With Set objSheet = Nothing End Sub

Beliebteste Forumthreads (12 Monate)

VBA Excel-Dateien/-blätter zusammenfassen

7 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread