Gruppe
Datei
Problem
Alle Arbeitsmappen in dem in Zelle B1 genannten Verzeichnis sollen geöffnet und der mit Zelle A1 zusammenhängende Bereich des 3. Tabellenblattes in dieses Blatt kopiert werden.
StandardModule: Modul1
Sub Zusammenfassen()
Dim wkb As Workbook
Dim wks As Worksheet
Dim arr As Variant
Dim lRow As Long
Dim iCounter As Integer
Dim sFile As String
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo ERRORHANDLER
Set wks = ActiveSheet
sFile = Range("B1").Value
arr = FileArray(sFile, "*.xls")
For iCounter = 1 To UBound(arr)
Set wkb = Workbooks.Open(sFile & "\" & _
arr(iCounter))
lRow = wks.Cells(Rows.Count, 1).End(xlUp).Row + 2
wks.Cells(lRow, 1).Value = wkb.Name
lRow = lRow + 2
wkb.Worksheets(3).Range("A1").CurrentRegion.Copy wks.Cells(lRow, 1)
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