Gruppe
Datei
Bereich
Arbeitsmappe
Thema
Erste Blätter aus allen Dateien eines Verzeichnisses sammeln
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