ich hab hier im Forum den folgenden Code, der auch super funktioniert, gefunden.
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
Ich möchte nun nicht die einzelnen .xml-Dateien angezeigt bekommen, sondern nur noch alle Unterordner die sich im "Film_Certificate" Ordner befinden. Wie müsste das Script geändert werden damit nur die Ordner gelistet werden.
Für zweckdienliche Hinweise herzlichen Dank.