Sub Merge_tables()
Dim strVerzeichnis As String
Dim strTyp As String
Dim strDateiname As String
Dim lngZeile As Long
Dim nbr As Long
nbr = 0
strTyp = "*.xls*"
Application.ScreenUpdating = False
strVerzeichnis = "Ordnerpfad"
strDateiname = Dir(strVerzeichnis & strTyp)
lngZeile = 10
With ThisWorkbook.Worksheets("Tabelle1")
Do While strDateiname <> ""
nbr = nbr + 1
If nbr = 1 Then
Workbooks.Open Filename:=strVerzeichnis & strDateiname
Letzte_zeile = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1
ActiveWorkbook.Worksheets(1).Range("A1:CZ" & Letzte_zeile).Copy .Cells(1, 1)
ActiveWorkbook.Close True
strDateiname = Dir
lngZeile = lngZeile + Letzte_zeile - 10
Else
Workbooks.Open Filename:=strVerzeichnis & strDateiname
Letzte_zeile = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 5).End(xlUp).Row + 1
ActiveWorkbook.Worksheets(1).Range("D10:CZ" & Letzte_zeile).Copy .Cells(lngZeile, 4)
ActiveWorkbook.Close True
strDateiname = Dir
lngZeile = lngZeile + Letzte_zeile - 10
End If
Loop
End With
Application.ScreenUpdating = True
End Sub