Gruppe
Datei
Problem
Alle Arbeitsmappen eines vorgegebenen Verzeichnisses öffnen und das dort einzig vorhandene Tabellenblatt in diese Arbeitsmappe kopieren.
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