Hallo,

vielleicht hilft dieser Code:

Sub TEST()
    Dim mySearchFolders As New clsSearchFolders
    
    Dim myCol As Collection
    Dim strSearchPath As String
    Dim strRootPath As String
    
    strRootPath = "L:\temp\"
    strSearchPath = "archiv"
    
    ' Case-Sensitive Suche nach Teilpfad
    Set myCol = mySearchFolders.SearchSubPaths(strRootPath, strSearchPath, True)
    
    ' oder Suche nach Teilpfad ohne Case-Sensitive
    Set myCol = mySearchFolders.SearchSubPaths(strRootPath, strSearchPath, False)
    

End Sub

Zusätzlich muss eine Klassenmodul mit dem Namen clsSearchFolders angelegt werden:

Option Explicit

Private myRootPath As String
Private myWorkCol As Collection

Public Function SearchSubPaths(strFolder As String, strSearchFolder As String, Optional ByVal caseSensitiveSearch As Boolean = False) As Collection
    Set myWorkCol = New Collection
    strFolder = strFolder & IIf(Right(strFolder, 1) = "\", "", "\")
    myWorkCol.Add strFolder
    Set SearchSubPaths = SearchSubFolders(strSearchFolder, caseSensitiveSearch)
End Function

Private Function SearchSubFolders(strSearchFolder As String, caseSensitiveSearch As Boolean) As Collection
    Dim colOut As New Collection
    Dim strTemp As String
    Do Until myWorkCol.Count = 0
        strTemp = Dir(myWorkCol.Item(1), vbDirectory)
        Do Until strTemp = vbNullString
            If Not (strTemp = "." Or strTemp = "..") Then
                If GetAttr(myWorkCol.Item(1) & strTemp) = vbDirectory Then
                    myWorkCol.Add myWorkCol.Item(1) & strTemp & "\"
                End If
            End If
            strTemp = Dir()
        Loop
        If (InStr(myWorkCol.Item(1), strSearchFolder) > 0 And caseSensitiveSearch) Or (InStr(LCase(myWorkCol.Item(1)), LCase(strSearchFolder)) > 0 And Not caseSensitiveSearch) Then
            colOut.Add myWorkCol.Item(1)
        End If
        myWorkCol.Remove 1
    Loop
    If colOut.Count > 0 Then
        sortCollection colOut, True
    End If
    Set SearchSubFolders = colOut
End Function


Private Sub sortCollection(ByRef col As Collection, Optional ByVal bUp As Boolean = True)
    Dim vItem As Variant
    Dim iPos As Integer
    iPos = 1
    Do While col.Count > iPos
        If (col.Item(iPos) > col.Item(iPos + 1) And bUp) Or (col.Item(iPos) < col.Item(iPos + 1) And Not bUp) Then
            vItem = col.Item(iPos)
            col.Remove iPos
            col.Add Item:=vItem, After:=iPos
            'Set col.Item(iPos) = col.Item(iPos + 1)
            'Set col.Item(iPos + 1) = vItem
            iPos = iPos - IIf(iPos > 1, 1, 0)
        Else
            iPos = iPos + 1
        End If
    Loop
End Sub

Als Ergebnis erhält man eine Collection mit den gesuchten Pfaden.

LG, BigBen