如何遍历文件夹 A 的子文件夹以获取每个子文件夹中的文件名，并使用 VBA 从文件夹 B 复制其他同名文件

Question

文件夹A包含多个子文件夹，如A1、A2、A3等，每个子文件夹大多有一个有时2个字的文件，其中包含名称（例如file_a1）。然后，还有另一个文件夹 B（不是 A 的子文件夹），其中包含多个具有标准相似 (file_a1_XZ) 名称的单词文件。 我想在 A 的子文件夹中循环并将 word 文件从 B 复制到相应的子文件夹，例如 A1

文件结构：

Parent Folder
|
|
 ----Parent B
     |
     |
      --- B
          |
           -file_a1_XZ
           -file_a2_XZ
 ----Parent A
     |
     |
      --- A
          |
          |
           -- A1
              |
               -file_a1
           -- A2
              |
               -file_a2

Answer 1

使用 Dir

将文件移动到特定文件夹

• 将文件从 B 移动到 A 的子文件夹，即文件名包含子文件夹的名称。

Option Explicit

Sub MoveFiles()
    
    Const sFolderPath As String = "C:\Test\T2022752347\B\"
    Const dFolderPath As String = "C:\Test\T2022752347\A\"
    Const sExtensionPattern As String = ".doc*"
    
    Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Do Until Len(dFolderName) = 0
        If dFolderName <> "." And dFolderName <> ".." Then
            dict(dFolderName) = Empty
        End If
        dFolderName = Dir
    Loop
    
    Dim Key As Variant
    Dim sFileName As String
    Dim fCount As Long
    
    For Each Key In dict.Keys
        
        sFileName = Dir(sFolderPath & "*" & Key & "*" & sExtensionPattern)
        
        Do Until Len(sFileName) = 0
            fCount = fCount + 1
            FileCopy sFolderPath & sFileName, _
                dFolderPath & Key & "\" & sFileName
            Kill sFolderPath & sFileName
            sFileName = Dir
        Loop
    
    Next

    MsgBox "Files moved: " & fCount, vbInformation

End Sub

• 如果B中的文件在各个子文件夹中，使用下面的。

Sub MoveFiles()
    
    Const sFolderPath As String = "C:\Test\T2022752347\B\"
    Const dFolderPath As String = "C:\Test\T2022752347\A\"
    Const sExtensionPattern As String = ".doc*"
    
    Dim dFolderName As String: dFolderName = Dir(dFolderPath, vbDirectory)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    
    Do Until Len(dFolderName) = 0
        If dFolderName <> "." And dFolderName <> ".." Then
            dict(dFolderName) = Empty
        End If
        dFolderName = Dir
    Loop
    
    Dim sFilePaths() As String
    Dim sFilePath As String
    Dim dFilePath As String
    Dim Key As Variant
    Dim f As Long
    Dim fCount As Long
    
    For Each Key In dict.Keys
        sFilePaths = ArrFilePaths(sFolderPath, _
            "*" & Key & "*" & sExtensionPattern)
        For f = 0 To UBound(sFilePaths)
            fCount = fCount + 1
            sFilePath = sFilePaths(f)
            dFilePath = dFolderPath & Key & "\" & Right(sFilePath, _
                Len(sFilePath) - InStrRev(sFilePath, "\"))
            FileCopy sFilePath, dFilePath
            Kill sFilePath
        Next f
    Next Key
        
    MsgBox "Files moved: " & fCount, vbInformation

End Sub

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' Purpose:      Returns the file paths of the files in a folder
'               in a zero-based string array.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Function ArrFilePaths( _
    ByVal FolderPath As String, _
    Optional ByVal FilePattern As String = "*.*", _
    Optional ByVal DirSwitches As String = "/s/b/a-d") _
As String()
    Const ProcName As String = "ArrFilePaths"
    On Error GoTo ClearError
    
    ' Ensuring that a string array is passed if an error occurs.
    ArrFilePaths = Split("") ' LB = 0 , UB = -1
   
    Dim pSep As String: pSep = Application.PathSeparator
    If Right(FolderPath, 1) <> pSep Then FolderPath = FolderPath & pSep
    Dim ExecString As String ' '%comspec%' or 'cmd.exe' ?
    ExecString = "%comspec% /c Dir """ _
        & FolderPath & FilePattern & """ " & DirSwitches
    Dim Arr() As String: Arr = Split(CreateObject("WScript.Shell") _
        .Exec(ExecString).StdOut.ReadAll, vbCrLf)
    If UBound(Arr) > 0 Then
        ReDim Preserve Arr(0 To UBound(Arr) - 1)
    End If
    ArrFilePaths = Arr

ProcExit:
    Exit Function
ClearError:
    Debug.Print "'" & ProcName & "' Run-time error '" _
        & Err.Number & "':" & vbLf & "    " & Err.Description
    Resume ProcExit
End Function