FSO несколько подстановочных знаков для пути к папке

Question

Можно ли добавить также подстановочный знак в путь к папке? Есть 4 уровня папок. Main_folder: путь известен Подпапки 1: foldername частично известно. В моем примере 4 . Есть папка 4.1 и 4.2 (также 5.1, 5.2, 6.1 и 6.2), но я не знаю, где будут файлы подпапки 2: путь известен подпапки 4: здесь находятся папки, которые мне нужно скопировать.

FSO.copyfolder "C:\Users\USER\Desktop\retrieve test\New folder\4*\*" & wb.Sheets("Sheet3").Range("B1") & "*", "C:\Users\USER\Desktop\retrieve test\Lay\Lay"

Ниже приведен пример копирования правильных папок, но здесь определена моя третья папка (она должна быть переменной)

FSO.copyfolder "C:\Users\USER\Desktop\retrieve test\New folder\4.1\*" & wb.Sheets("Sheet3").Range("B1") & "*", "C:\Users\USER\Desktop\retrieve test\Lay\Lay"

Макрос должен выполнить l oop во всех папках, чтобы найти частичное имя, определенное в B1 на листе 3.

Answer 1

Предыдущий ответ был основан на моих недоразумениях и файлах. Это было изменено таким образом, чтобы при наличии нескольких файлов в каждой папке дублировалось одно и то же имя папки, поэтому извлекалась только одна уникальная папка, а папка копировалась в папку назначения.

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

Назначение изображение папки

Answer 2

Ранее, если вам нужно было собрать все папки, а затем скопировать папку, соответствующую условиям, будут собраны только папки, соответствующие условиям, и затем скопированы. Это более эффективно.

Option Explicit

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

    Dim strFolder As String, TargetFolder As String
    Dim i As Long
    Dim vSplit
    Dim 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, "\")

        FS.CopyFolder vR(i), TargetFolder & vSplit(2)
    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
    Dim s As String
    Dim vSplit

    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
        s = f.Path
        s = Replace(s, "C:\Users\USER\Desktop\retrieve test\New folder\", "")
        's = Replace(s, "C:\Users\Admin\Documents\", "")

        vSplit = Split(s, "\")
        If UBound(vSplit) = 2 Then
            If InStr(vSplit(2), str) Then
                n = n + 1
                ReDim Preserve vR(1 To n)
                vR(n) = f.Path
            End If
        End If
        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
    Dim s As String
    Dim vSplit
    Dim Wb As Workbook
    Dim str As String

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

    For Each sbFolder In objFolder.SubFolders
        s = sbFolder.Path
        s = Replace(s, "C:\Users\USER\Desktop\retrieve test\New folder\", "")
        's = Replace(s, "C:\Users\Admin\Documents\", "")

        vSplit = Split(s, "\")
        If UBound(vSplit) > 2 Then Exit Sub
        SearchSubfolder sbFolder
        If UBound(vSplit) = 2 Then
            If InStr(vSplit(2), str) Then
                n = n + 1
                ReDim Preserve vR(1 To n)
                vR(n) = sbFolder.Path
            End If
        End If
    Next sbFolder

End Sub