FSO文件夹路径的多个通配符

先前的答案是基于我的误解和档案。已对此进行了修改，以便如果每个文件夹中有多个文件，则重复相同的文件夹名称，因此仅提取唯一的单个文件夹，并将该文件夹复制到目标文件夹。

Option Explicit

Dim vR()
Dim n As Long
Sub copyFileFromFolder()

    Dim strFolder As String, TargetFolder As String
    Dim i As Long
    Dim vSplit
    Dim str As String, Path As String
    Dim Wb As Workbook
    Dim FS As Scripting.FileSystemObject

    Set FS = New Scripting.FileSystemObject

    strFolder = "C:\Users\USER\Desktop\retrieve test\New folder\"
    TargetFolder = "C:\Users\USER\Desktop\retrieve test\Lay\Lay\"

    '*** The folder address below is for my test.
    'strFolder = "C:\Users\Admin\Documents\"                 '<~~ for my test -->It corresponds to  your New folder
    'TargetFolder = "C:\Users\Admin\Documents\target\"       '<~~ for my test

    Set Wb = ThisWorkbook
    str = Wb.Sheets("Sheet3").Range("B1")

    SearchFolder strFolder
    On Error Resume Next
    For i = 1 To n
        Path = vR(i)
        Path = Replace(Path, strFolder, "")
        vSplit = Split(Path, "\")
        If UBound(vSplit) = 2 Then
            If InStr(vSplit(2), str) Then
                FS.CopyFolder vR(i), TargetFolder & vSplit(2)
            End If
        End If
    Next i

    '** Show Root folder's subfolders

    With Sheets.Add ' set Sheets("your sheets's name)
        .UsedRange.Offset(1).ClearContents
        .Range("a2").Resize(n) = WorksheetFunction.Transpose(vR)
    End With
    Erase vR
    n = 0
End Sub
Sub SearchFolder(strRoot As String)
    Dim FS As Scripting.FileSystemObject
    Dim fsFD As Folder
    Dim f As Folder
    Dim p As String

    On Error Resume Next
    p = Application.PathSeparator
    If Right(strRoot, 1) = p Then
    Else
        strRoot = strRoot & p
    End If
    Set FS = New Scripting.FileSystemObject

    Set fsFD = FS.GetFolder(strRoot)
    For Each f In fsFD.SubFolders
        n = n + 1
        ReDim Preserve vR(1 To n)
        With f
            vR(n) = f.Path
        End With
        SearchSubfolder f
    Next f

    Set fsFD = Nothing
    Set FS = Nothing

End Sub
Sub SearchSubfolder(objFolder As Folder)
    Dim sbFolder As Object
    Dim f As Folder
    For Each sbFolder In objFolder.SubFolders
        SearchSubfolder sbFolder
        n = n + 1
        ReDim Preserve vR(1 To n)
        vR(n) = sbFolder.Path
    Next sbFolder

End Sub

目标文件夹图像