Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Bewerten Sie hier bitte das Excel-Portal

Home Zurück Vor

Download Beispiel-Arbeitsmappe

Thema

Erste Blätter aus allen Dateien eines Verzeichnisses sammeln

Gruppe

Arbeitsmappe

Problem

Alle Arbeitsmappen eines vorgegebenen Verzeichnisses öffnen und das dort einzig vorhandene Tabellenblatt in diese Arbeitsmappe kopieren.

Lösung

Den nachstehenden Code in ein Standardmodul eingeben, einer Schaltfläche zuweisen und starten.

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