Daten aus mehreren Excel-Dateien zusammenfügen
20.11.2018 09:40:21
Robert
ich arbeite schon länger mit Excel und beschäftige mich hin und wieder mit dem Macro Recorder für VBA Codes.
Nun habe ich den Fall, dass mir eine liebe Kollegin jedes Monat von einem externen Unternehmen Excelfiles in einem Ordner abspeichert - Spalten alle gleich - Zeilen jedoch immer sehr unterschiedlich lang.
Jedes Mal sind es doch 20 die händisch zusammen kopiert werden müssen um eine kurze Pivot für eine Auswertung vornehmen zu können.
Nach ein wenig Recherche und ausprobieren bin ich auf folgenden Code im Archiv gesstoßen:
Sub Zusammenführen()
Dim i As Long
Dim sPfad As String
Dim sDatei As String
Dim vFileToOpen As Variant
Dim lngLZ As Long
Dim blnÜberschrift As Boolean
Dim iCalc As Integer
vFileToOpen = Application.GetOpenFilename("Excel Files (*.xls*), *.xls*", , , , True)
If Not IsArray(vFileToOpen) Then Exit Sub
iCalc = Application.Calculation
On Error GoTo ENDE:
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
For i = 1 To UBound(vFileToOpen)
sDatei = Dir(vFileToOpen(i))
sPfad = Left(vFileToOpen(i), InStr(vFileToOpen(i), sDatei) - 1)
With Tabelle1.Range("A1")
.Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$A:$A""""),ROW('" _
_
_
& sPfad & "\[" & sDatei & "]Tabelle1'!$A:$A))"
lngLZ = .Value
End With
With Tabelle1
If blnÜberschrift Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 43).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 43).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A1"
End If
End With
Next
With Tabelle1.UsedRange
.Copy
.PasteSpecial xlPasteValues
.Rows(1).Delete
End With
ENDE:
Application.EnableEvents = True
Application.Calculation = iCalc
Application.ScreenUpdating = True
If Err Then MsgBox Err.Description, , "Fehler: " & Err
End Sub
Ich hoffe jemand kann mir hier ein wenig aushelfen!
beste Grüße - Robert