Code

Sub Mehrere_Dateien_auswaehlen() 
 
Dim arrDateien As Variant 
Dim wbQuelle As Workbook 
Dim LetzteZeile As Long 
Dim cntDatei As Long 
Dim rngQuelle As Range 
 
'Screenupdating und PopUps deaktivieren 
Application.ScreenUpdating = False 
Application.DisplayAlerts = False 
 
'Benutzer Dateien auswählen lassen 
arrDateien = Application.GetOpenFilename(filefilter:="Excel-Dateien (*.xls*),*.xls*", MultiSelect:=True) 
 
'Wurde eine Datei ausgewählt? 
If IsArray(arrDateien) Then 
 
    'Schleife über alle ausgewählten Dateien 
    For cntDatei = 1 To UBound(arrDateien) 
     
        LetzteZeile = ThisWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Row 
         
        'Aktuelle Arbeitsmappe öffnen 
        Set wbQuelle = Workbooks.Open(Filename:=arrDateien(cntDatei)) 
         
        'Daten-Range setzen 
        Set rngQuelle = wbQuelle.Worksheets(1).Range("B2").CurrentRegion 
         
        'Daten kopieren und einfügen 
        Intersect(rngQuelle, rngQuelle.Offset(1, 0)).Copy 
        ThisWorkbook.Worksheets(1).Range("A" & LetzteZeile + 1).PasteSpecial 
         
        'Arbeitsmappe schließen 
        wbQuelle.Close SaveChanges:=False 
    Next cntDatei 
 
End If 
 
'Screenupdating und PopUps aktivieren 
Application.ScreenUpdating = True 
Application.DisplayAlerts = True 
 
'Bereitgestellt von VBATrainer: www.vbatrainer.de

End Sub