Hallo,
es mussten folgende Änderungen vorgenommen werden:
With Tabelle1.Range("A1")
.Formula = "=LOOKUP(2,1/('" & sPfad & "[" & sDatei & "]Tabelle1'!$C:$C<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle1'!$C:$C))-9"
lngLZ = .Value
End With
In der Formula Zeile muss die Angabe $A:$A nach $C:$C geändert werden.
Zusätzlich müssen die ersten 9 Zeilen abgezogen werden. Daher "-9" am Ende.
If blnÜberschrift Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 5).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!C11"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!C10"
End If
In diesem Bereich müssen nur zwei Änderungen vorgenommen werden:
Daten: 'Tabelle1'!A2 muss nach 'Tabelle1'!C11 geändert werden
Überschrift: 'Tabelle1'!A1 muss nach 'Tabelle1'!C10 geändert werden.
Der neue Code schaut nach den Änderungen wie folgt aus:
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'!$C:$C<>""""),ROW('" & sPfad & "\[" & sDatei & "]Tabelle1'!$C:$C))-9"
lngLZ = .Value
End With
With Tabelle1
If blnÜberschrift Then
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ - 1, 5).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!C11"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!C10"
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 <= 0 Then
Application.StatusBar = False
Application.DisplayStatusBar = oldStatusBar
End If
End Sub
Während der Ausführung ist mir aufgefallen, dass nur die ersten 5 Überschriften importiert werden, obwohl in den Daten 30 Überschriften vorhanden sind.
LG, BigBen
|