Gruppe
Datei
Bereich
Arbeitsmappe
Thema
Arbeitsmappen öffnen und Bereiche kopieren
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.
Lösung
Geben Sie den Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.
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