Excel und VBA: Formeln, Programmierung, Lösungen

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

    

Beiträge aus dem Excel-Forum zu den Themen Datei und Arbeitsmappe