Thema: Daten aus geschlossenen Arbeitsmappen listen

StandardModule: basMain

Sub DateienAuslesen()
   Dim rng As Range
   Dim arr As Variant
   Dim iCounter As Integer, iRow As Integer, iAct As Integer
   Dim sPath As String, sFormula As String, sTmp As String
   Application.ScreenUpdating = False
   sPath = Range("B1").Value
   arr = FileArray(sPath, "*.xls")
   For iCounter = 1 To UBound(arr)
      If FileDateTime(sPath & arr(iCounter)) <= Date + 1 Then
         With Worksheets("Import")
            If IsEmpty(.Cells(1, 1)) Then
               Set rng = .Range("A1")
            Else
               Set rng = .Cells(Rows.Count, 1).End(xlUp).Offset(1, 0)
            End If
         End With
         rng.Value = sPath & arr(iCounter)
         sFormula = "='"
         sFormula = sFormula & sPath & "["
         sFormula = sFormula & arr(iCounter) & "]"
         sFormula = sFormula & "Tabelle1'!"
         sTmp = Right(sFormula, Len(sFormula) - 1)
         sFormula = sFormula & "F1"
         rng.Offset(0, 1).Formula = sFormula
         rng.Offset(0, 2).Formula = "=counta(" & sTmp & "F:F)"
         iRow = rng.Offset(0, 2).Value
         If iRow > 0 Then
            rng.Offset(0, 2).Formula = "=" & sTmp & "F" & iRow
         Else
            rng.Offset(0, 2).ClearContents
         End If
      End If
   Next iCounter
   With Worksheets("Import").Range("A1").CurrentRegion
      .Value = .Value
   End With
End Sub

Function FileArray(sPath As String, sPattern As String)
   Dim arr()
   Dim iCounter As Integer
   Dim sFile As String
   If Right(sPath, 1) <> "\" Then sPath = sPath & "\"
   sFile = Dir(sPath & sPattern)
   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