Excel - Dateien zusammenfassen zusammenführen - untereinander - gleicher Ordner

 
Sub makro1()
Worksheets(1).Activate
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select  
aname = ActiveWorkbook.Name

Cells(1, 2) = "ID"  
Cells(1, 3) = "Nummer"  

pfad1 = ActiveWorkbook.Path & "\"              
name1 = Dir(pfad1, vbNormal)                  

Do While name1 <> ""                            
    If name1 <> aname Then                   
        If Right(name1, 4) = ".xls" Then         
            GoSub uebernehmen
        End If
    End If
    name1 = Dir                                
Loop
    Cells.Select                               
    Cells.EntireColumn.AutoFit                 
    Cells(1, 1).Select                        
Exit Sub                                      

uebernehmen:
Workbooks.Open Filename:=pfad1 & name1
Worksheets(1).Activate
lz = Range("b65536").End(xlUp).Row               
If lz > 1 Then
    Range(Cells(2, 2), Cells(lz, 18)).Select      
    Selection.Copy                                
    Windows(aname).Activate                       
    l1 = Range("a65536").End(xlUp).Row + 1           
    Cells(l1, 2).Activate                          
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False                
    Application.DisplayAlerts = False              
    Windows(name1).Close                          
    Application.DisplayAlerts = True             
    l2 = Range("b65536").End(xlUp).Row              
    Range(Cells(l1, 1), Cells(l2, 1)) = name1   
   
    Else
    Windows(name1).Close                           
End If
Return                                         
End Sub