Microsoft Excel

Excel und VBA: Formeln, Programmierung, Lösungen

Die Excel/VBA-Beispiele

Thema

Daten aus geschlossenen Arbeitsmappen listen

Gruppe

Arbeitsmappe

Problem

Aus dem Verzeichnis c:\temp soll aus allen Excel-Tabellen der erste und letzte Wert in Spalte F ausgelesen werden, ohne dass diese Arbeitsmappen geöffnet werden. Die Werte sind durchgehend eingetragen.

Lösung
Geben Sie den nachfolgenden Code in ein Standardmodul ein und weisen Sie ihn einer Schaltfläche zu.

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