Makro"Daten aus Tabellen lesen"

Sub dateienAuslesen()

Dim rng As Range
Dim arrf As Variant
Dim intc As Integer
Dim intr As Integer
Dim inta As Integer
Dim strp As String
Dim strf As String
Dim strt As String

Application.screenupdating = False

strp = "H:\"
arrf = filearray(strp, "*.xls")
For intc = 1 To UBound(arrf)
If FileDateTime(strp & arrf(intc)) <= Date + 1 Then
If IsEmpty(Cells(7, 3)) Then
Set rng = Range("C7")
Else: Set rng = Cells(Rows.Count, 3).End(xlUp).Offset(1, 0)
End If
rng.Value = strp & arrf(intc)
strf = "='"
strf = strf & strp & "["
strf = strf & arrf(intc) & "]"
strf = strf & "Tabelle1'!"
strt = Right(strf, Len(strf) - 1)
strf = strf & "F1"
rng.Offset(0, 1).Formula = strf
rng.Offset(0, 2).Formula = "=counta(" & strt & "F:F)"
intr = rng.Offset(0, 2).Value
If intr > 0 Then
rng.Offset(0, 2).Formula = "=" & strt & "F" & intr
Else: rng.Offset(0, 2).ClearContents
End If
End If
Next intc

End Sub

Function filearray(strp As String, strpa As String)

Dim arrdn()
Dim intc As Integer
Dim dtrd As String

If Right(strp, 1) <> "\" Then strp = strp & "\"
strd = Dir(strp & strpa)
Do While strd <> ""
intc = intc + 1
ReDim Preserve arrdn(1 To intc)
arrdn(intc) = strd
strd = Dir()
Loop
filearray = arrdn

End Function