FSO文件夹路径的多个通配符 [英] FSO multiple wildcards for folder path

问题描述

是否可以在文件夹路径中添加通配符?共有4级文件夹.
Main_folder:路径已知
子文件夹1:文件夹名称部分已知.在我的示例 4 中.有一个文件夹4.1和4.2(还有5.1、5.2、6.1和6.2)，但我不知道文件在哪里结束
子文件夹2:已知路径
子文件夹4:这是文件夹找到我需要复制的位置.

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"

宏需要做的是循环遍历所有文件夹，以找到工作表3 B1中定义的部分名称.

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.

推荐答案

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

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

目标文件夹图像

这篇关于FSO文件夹路径的多个通配符的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！