Zusammenführung mehrer Excel Dateien
13.11.2018 14:01:01
Stefan
-In verschiedenen Ordner befinden sich gleich strukturierte Excel- Dateien mit jeweils 2 Tabellenblättern, wobei jeweils nur die Informationen aus dem 1. Tabellenblatt, ab Zeile A3 herauskopiert werden sollen. (kopiert werden sollen nur die Zellen mit Werten)
- Die Dateien sollen per Auswahl aus den verschiedenen Ordner in die die aktuelle Excel Datei eingefügt werden (Also z.B. aus Ordner 1, Datei 3 und 4....Informationen werden gezogen... Klick auf Datei auswählen- Button... Aus Ordner 4, Datei 6-10) Die Informationen sollen jeweils untereinander weg ab Zeile A2 (hier befinden sich Überschriften) gelistet werden.
Da ich ein absoluter Neuling bin, weiß ich leider nicht, wie ich das umsetzen kann! Ich habe _
bereits mit folgendem Code herumgebastelt (ebenfalls aus dem Internet), leider funktioniert _ dieser nicht einwandfrei, da die erste Zeile (Überschriftenzeile) überschrieben wird und zwischen den einzelnen ausgewählten Zeilen immer eine Zeile mit 0- Werten eingefügt wird. Vll. kann mir hier jemand weiterhelfen? Das wäre super!
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("A2")
.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, 12).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 12).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A2"
End If
End With
Call StatusBalken(Int((i / UBound(vFileToOpen)) * 100))
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
Sub StatusBalken(ProzentSatz) ''ProzentSatz = Int((i / 10000) * 100)
Dim Mess, Z, Rest
Static oldStatusBar As Integer
Static blnInit As Boolean
If Not blnInit Then
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
End If
Mess = ""
For Z = 1 To ProzentSatz
Mess = Mess & ChrW(Val("&H25A0"))
Next Z
Rest = 100 - ProzentSatz
For Z = 1 To Rest
Mess = Mess & ChrW(Val("&H25A1"))
Next Z
Application.StatusBar = Mess & " " & ProzentSatz & "%"
If Rest