I appreciate all the help with my last question

This is the ideal output.

CodePudding user response：

Please, try the next way. Since you cannot use Dir in two different loops, in the Sub I will use "Scripting.FileSystemObject", to iterate between the main folder subfolders:

Sub extractSubfolderPathFromSubfolders()
    Dim sh As Worksheet, lastRow As Long, i As Long, fldName As String
    Dim FSO As Object, fld As Object, subFld As Object
    Const foldPath As String = "C:\Users\User1\Downloads\Test\"
    
    Set sh = ActiveSheet
    lastRow = sh.Range("A" & sh.rows.count).End(xlUp).row
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set fld = FSO.GetFolder(foldPath)
    
    For i = 2 To lastRow
        For Each subFld In fld.SubFolders
            fldName = getFoldPath(CStr(subFld), sh.Range("A" & i).value)
            If fldName <> "" Then
                sh.Range("B" & i).value = subFld & "\" & fldName
            End If
        Next
    Next i
End Sub

And a function able to return a directory knowing its partial name. It is called by the above sub:

Function getFoldPath(dirFolder As String, strToFind As String) As String
    Dim fldName As String
    If Right(dirFolder, 1) <> "\" Then dirFolder = dirFolder & "\"
    fldName = Dir(dirFolder & "*" & strToFind & "*", vbDirectory)
    Do While fldName <> ""
        If fldName <> "." And fldName <> ".." Then
            ' Use bitwise comparison to make sure dirFolder is a directory.
            If (GetAttr(dirFolder & fldName) And vbDirectory) = vbDirectory Then
                getFoldPath = fldName: Exit Function
            End If
        End If
        fldName = Dir
    Loop
End Function

I need to close my computer now. If something does not work as you need, please try explaining why. I will adapt the code tomorrow...