Thema: Erste Blätter aus allen Dateien eines Verzeichnisses sammeln

StandardModule: Modul1

Sub Zusammenfassen()
   Dim wkb As Workbook
   Dim arr As Variant
   Dim iCounter As Integer
   Dim sFile As String
   Application.ScreenUpdating = False
   Application.EnableEvents = False
   On Error GoTo ERRORHANDLER
   sFile = Range("B1").Value
   arr = FileArray(sFile, "*.xls")
   For iCounter = 1 To UBound(arr)
      Set wkb = Workbooks.Open(sFile & "\" & _
         arr(iCounter))
      wkb.Worksheets.Add
      wkb.Worksheets(2).Move _
         after:=ThisWorkbook.Worksheets( _
            ThisWorkbook.Worksheets.Count)
      wkb.Close savechanges:=False
   Next iCounter
   Worksheets(1).Select
ERRORHANDLER:
   Application.EnableEvents = True
   Application.ScreenUpdating = True
End Sub

Function FileArray(ByVal strPath As String, _
   sPattern As String)
   Dim arr()
   Dim iCounter As Integer
   Dim sFile As String
   If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
   sFile = Dir(strPath & sPattern)
   If sFile = "" Then
      Beep
      MsgBox "Keine Dateien gefunden!"
      End
   End If
   Do While sFile <> ""
       iCounter = iCounter + 1
       ReDim Preserve arr(1 To iCounter)
       arr(iCounter) = sFile
       sFile = Dir()
   Loop
   FileArray = arr
End Function

Beiträge aus dem Excel-Forum zu den Themen Datei und Arbeitsmappe