FSO multiple wildcards for folder path

user_12985386 0
Viewed 637

Is it possible to add also a wildcard in the folder path? There are 4 levels of folders.
Main_folder: path is known
Subfolders 1: foldername is partially known. In my example 4. There is a folder 4.1 and 4.2(also 5.1, 5.2, 6.1 and 6.2) but I don`t know where the files will end up
subfolders 2: path is known
subfolders 4: here are the folders located that I need to copy.

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

Below example works to copy the correct folders but here is my third folder defined (this should be variable)

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"

What the macro needs to do is loop through all the folders to find the partial name that is defined in B1 on sheet 3.

enter image description here

vba excel
2 Answers

The previous answer was based on my misunderstanding and file. This has been modified so that if there are multiple files in each folder, the same folder name is duplicated, so only a unique single folder is extracted and the folder is copied to the destination folder.

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

Destination folder image

enter image description here

user_81070920

Previously, if you had to collect all the folders and then copy the folder that meets the conditions, this will collect only the folders that meet the conditions and then copy. This is more efficient.

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
user_81070920
Related