Inhalte aller .xls* in einem Blatt zusammenführen

Sub Import()
' Alle *.xls* eines Verzeichnisses in 1 (das aktuelle) Sheet importieren
Dim FullName As String
Dim wbkZiel As Workbook
Dim z As Integer  'Zähler für Durchläufe
On Error GoTo ErrorHandler
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
.AskToUpdateLinks = False
.DisplayAlerts = False
.EnableEvents = False
End With
Const Pfad = "C:\Test\" '*** ANPASSEN ***
Const Extension = "*.xls*"       '*** ANPASSEN ***
Const MitKopfzeile = False        '*** ANPASSEN ***
FullName = Dir(Pfad & Extension)
'Prüfung, ob Ziel-Sheet leer ist
If WorksheetFunction.CountA(Cells) > 0 Then
If MsgBox("Das Tabellenblatt ist nicht leer," & vbCrLf _
& "sollen die Daten gelöscht werden?", vbCritical + vbYesNo, _
"Warn-Hinweis") = vbYes Then
Cells.Delete
Else
z = 1
End If
End If
Do While FullName  ""
Call CopyData(Pfad & FullName, MitKopfzeile, z)
FullName = Dir
z = z + 1
Loop
ErrorHandler:
With Application
.ScreenUpdating = True
.Calculation = xlCalculationAutomatic
.AskToUpdateLinks = True
.DisplayAlerts = True
.EnableEvents = True
End With
Dim intRow As Integer, intLastRow As Integer
intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For intRow = intLastRow To 1 Step -1
If Application.CountA(Rows(intRow)) = 0 Then
intLastRow = intLastRow - 1
Else
Exit For
End If
Next intRow
For intRow = intLastRow To 1 Step -1
If IsEmpty(Cells(intRow, 1)) Then
Rows(intRow).Delete
End If
Next intRow
End Sub

Const sSourcePath As String = "C:\Test"
Dim fso as Object, oFile as Object
Set fso = CreateObject("Scripting.FileSystemObject")
For Each oFile In fso.GetFolder(sSourcePath).Files
If LCase(Right(oFile.Name, 4)) = ".xls" Then
Application.Workbooks.Open (oFile.Path)
End If
Next