Excel: Makro soll mehrer Dateien auslesen und in einer neuen Datei zusammenfassen

Sub collectSheets()
On Error GoTo damn
  Dim ap As Excel.Application
  Dim wb As Excel.Workbook
  Dim sz As Excel.Worksheet
  Dim strPath As String, strFile As String
  Dim nextRow As Long

  strPath = "C:\Users\Excel_VBA\"  
  strFile = Dir(strPath)
  
  ' Ziel (current WB)  
  Set sz = ActiveWorkbook.ActiveSheet
  
  Set ap = CreateObject("Excel.Application")  
  
  nextRow = 1
  Do Until strFile = ""  
    Set wb = ap.Workbooks.Open(Filename:=strPath & strFile, ReadOnly:=True)
    wb.Sheets("Tabelle1").UsedRange.Copy  
    sz.Cells(nextRow, 1).PasteSpecial (xlPasteValues)
    
    Application.DisplayAlerts = False
    wb.Close
    Application.DisplayAlerts = True

    nextRow = sz.Cells.SpecialCells(xlLastCell).Row + 1

    strFile = Dir()
  Loop

damn:
  If Err.Number <> 0 Then MsgBox Err.Description
  ' Aufräumen  
  Application.DisplayAlerts = False
  Set wb = Nothing
  ap.Quit
  Set ap = Nothing
End Sub

Sub MergeWorksheets()
    Const FOLDER = "C:\Users\Desktop\Excel_VBA\"  
    Dim sh As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets(1)
        file = Dir(FOLDER & "\*.xlsx")  
        While file <> ""  
            Set sh = GetObject(file).Sheets(1)
               sh.Range("B1:B4").Copy  
         .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Transpose:=True  
            sh.Parent.Close False
            file = Dir()
        Wend
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub

 

Sub MergeWorksheets()
    Const FOLDER = "C:\Users\Desktop\Excel_VBA\"  
    Dim sh As Worksheet
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    With Sheets(1)
        file = Dir(FOLDER & "*.xlsx")  
        While file <> ""  
            Set sh = GetObject(file).Sheets(1)
               sh.Range("B1:B4").Copy  
         .Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial Paste:=xlPasteValuesAndNumberFormats, Transpose:=True  
            sh.Parent.Close False
            file = Dir()
        Wend
    End With
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
End Sub