Dateien zählen

Sub ListFiles()
Dim fSearch As FileSearch
Dim strPath As String, strFName As String
Dim blnSubF As Boolean
Dim iCnt As Integer
Dim arrFile() As Variant
Dim lastRow As Long, lRow As Long
Dim wks As Worksheet
Dim wksList As Worksheet
On Error GoTo Errorhandler
Set wksList = Sheets("Liste")
lastRow = IIf(wksList.Range("A65536") <> "", 65536, _
wksList.Range("A65536").End(xlUp).Row)
If lastRow < 2 Then Exit Sub
For lRow = 2 To lastRow
If Not SheetExist("Suche " & lRow - 1) Then
Set wks = Worksheets.Add(after:=Sheets(Sheets.Count))
wks.Name = "Suche " & lRow - 1
Else
Set wks = Sheets("Suche " & lRow - 1)
wks.Cells.ClearContents
End If
If wksList.Cells(lRow, 1) <> "" Then
strPath = wksList.Cells(lRow, 1)
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
strFName = wksList.Cells(lRow, 2)
If strFName = "" Then
strFName = "*.*"
Else
strFName = "*." & Replace(Replace(strFName, "*", ""), ".", "")
End If
blnSubF = UCase(wksList.Cells(lRow, 3)) = "JA"
Set fSearch = Application.FileSearch
With fSearch
.NewSearch
.LookIn = strPath
.SearchSubFolders = blnSubF
.FileType = msoFileTypeAllFiles
.Filename = strFName
.MatchAllWordForms = True
.Execute
If .FoundFiles.Count > 0 Then
ReDim arrFile(.FoundFiles.Count - 1, 0)
For iCnt = 0 To .FoundFiles.Count - 1
arrFile(iCnt, 0) = .FoundFiles(iCnt + 1)
Next
End If
End With
wks.Range(wks.Cells(1, 1), wks.Cells(UBound(arrFile, 1), 1)) = arrFile
wks.Columns("A:A").Sort Key1:=wks.Range("A1"), Order1:=xlAscending, _
Header:=xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom
Set wks = Nothing
End If
ReDim arrFile(0, 0)
Next
Errorhandler:
Err.Clear
Resume Next
End Sub

Private Function SheetExist(ByVal sheetName As String, Optional WbName As String) As Boolean
Dim wks As Worksheet
On Error GoTo Errorhandler
If WbName = "" Then WbName = ThisWorkbook.Name
For Each wks In Workbooks(WbName).Worksheets
If wks.Name = sheetName Then SheetExist = True: Exit Function
Next
Errorhandler:
SheetExist = False
End Function