There is folder A which contains multiple subfolders like A1,A2, A3 etc which every subfolder has mostly one sometimes 2 word files with the name(eg file_a1) in it. Then, there is other folder B (not a subfolder of A) which contains multiple word files with standard similar (file_a1_XZ) names. I want to loop in subfolders of A and copy word files from B to respective sub folder e.g A1

File Structure:

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

CodePudding user response：

Move Files to Specific Folders Using Dir

• Moves files from B to subfolders of A i.e. the filenames contain the names of the subfolders.

Option Explicit

Sub MoveFiles()
    
    Const sFolderPath As String = "C:\Test\T2022\71752347\B\"
    Const dFolderPath As String = "C:\Test\T2022\71752347\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

• If the files in B are in various subfolders, use the following.

Sub MoveFiles()
    
    Const sFolderPath As String = "C:\Test\T2022\71752347\B\"
    Const dFolderPath As String = "C:\Test\T2022\71752347\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