Arbeitsmappen öffnen und Bereiche kopieren

Home Zurück Vor

Download der Beispiel-Arbeitsmappe

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