Ordner in bestimmten Ordnern anzeigen

Sub FindFiles_Projekte_Film_Certificate()
Dim objFS_Film_Certificate As FileSearch
Dim obj_P As Variant, obj_Film_Certificate As Variant, arrFilesFound() As String
Dim varProjektFolder As Variant, FileCount As Long
On Error GoTo Fehler
'Verzeichnis mit Projektordnern wählen
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = "Bitte Verzeichnis mit ProjektOrdnern auswählen"
If .Show = -1 Then
varProjektFolder = .SelectedItems(1)
'Ordner der Projekte finden
obj_P = Dir(varProjektFolder & "\*", vbDirectory)
Do Until obj_P = ""
'Prüfen ob gefundenes Element einen Ordner2 enthält
Select Case VBA.GetAttr(obj_P & Application.PathSeparator & "Film_Certificate")
Case vbDirectory, vbDirectory + vbReadOnly, vbDirectory + vbReadOnly + vbArchive, _
vbDirectory + vbArchive
'Ordner2 durchsuchen
Set objFS_Film_Certificate = Application.FileSearch
With objFS_Film_Certificate
.NewSearch
.LookIn = varProjektFolder & Application.PathSeparator _
& obj_P & Application.PathSeparator & "Film_Certificate"
.SearchSubFolders = True
'Exceldateien finden
.Filename = "*.xml"
If .Execute > 0 Then
'Dateien in Array schrieben
For Each obj_Film_Certificate In .FoundFiles
FileCount = FileCount + 1
ReDim Preserve arrFilesFound(1 To FileCount)
arrFilesFound(FileCount) = obj_Film_Certificate
Next
End If
End With
Case Else
'do nothing
End Select
Resume01:
'nächsten ProjektOrdner finden
obj_P = VBA.Dir
Loop
End If
End With
If FileCount > 0 Then
'gefundenen Dateien weiterverarbeiten
'Dateiliste in neue Tabelle ausgeben
Worksheets.Add
For FileCount = 1 To FileCount
'      MsgBox "Datei " & FileCount & "  : " & arrFilesFound(FileCount)
Cells(FileCount + 1, 1) = arrFilesFound(FileCount)
Next
Else
MsgBox "No Files founds"
End If
Fehler:
With Err
Select Case .Number
Case 0
Case 53 'Datei wurde nicht gefunden
'MsgBox "Fehler-Nr. " & .Number & vbLf & .Description
Resume Resume01
Case 76 'Pfad nicht gefunden
'MsgBox "Fehler-Nr. " & .Number & vbLf & .Description
Resume Resume01
Case Else
MsgBox "Fehler-Nr. " & .Number & vbLf & .Description
End Select
End With
End Sub