Mehrere Tabellen tranponiert zusammenführen

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, 5).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A14"
Else
blnÜberschrift = True
.Cells(.Rows.Count, 1).End(xlUp).Offset(1).Resize(lngLZ, 5).Formula = _
"='" & sPfad & "[" & sDatei & "]Tabelle1'!A13"
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