I am trying to write a VBA code to consolidate Excel files from different folders to a single folder. Within each folder there is a single Excel, that I would like to move it to a single, compiled folder. Here is my code so far:

Sub move_data()

Dim FSO As Object
Dim FromPath As String
Dim ToPath As String
Dim Fdate As Date
Dim FileInFromFolder As Object


MkDir "C:\User\TEST\"        
FromPath = "C:\User\MainFolder\" 
ToPath = "C:\User\TEST\"     
    
Set FSO = CreateObject("scripting.filesystemobject")

If FSO.FolderExists(FromPath) = False Then
    MsgBox FromPath & " doesn't exist"
    Exit Sub
End If

For Each FileInFromFolder In FSO.GetFolder(FromPath).Files
    FileInFromFolder.Move ToPath
Next FileInFromFolder

End Sub

The code is incomplete. It is unable to get the files from the subfolder within the folder (as shown in the image). May I seek advice from you all on how I can improve this code further?

The area I am looking to change is 'FromPath', if it is possible to include a wildcard to specify the subfolders?

Hope to hear from you all soon. Thank you in advance!

Multiple Folders, One Excel per Folder

CodePudding user response：

Move Files From Multiple Folders to Single Folder (FileSystemObject)

Sub MoveFiles()

    Const FromPath As String = "C:\MainFolder\"
    Const ToPath As String = "C:\Test\"
    Const LCaseExtensionPattern As String = "xls*"
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    If Not fso.FolderExists(FromPath) Then
        MsgBox "The folder '" & FromPath & "' doesn't exist.", vbCritical
        Exit Sub
    End If
    
    If Not fso.FolderExists(ToPath) Then MkDir ToPath
    
    Dim SubFolderPaths() As String: SubFolderPaths = ArrSubFolderPaths(FromPath)
    
    Dim fsoFile As Object
    Dim NotMoved() As String
    Dim n As Long
    Dim mCount As Long
    Dim nmCount As Long
    
    For n = 0 To UBound(SubFolderPaths)
        For Each fsoFile In fso.GetFolder(SubFolderPaths(n)).Files
            If LCase(fso.GetExtensionName(fsoFile)) _
                    Like LCaseExtensionPattern Then
                If Not fso.FileExists(ToPath & fsoFile.Name) Then
                    mCount = mCount   1
                    fsoFile.Move ToPath
                Else
                    nmCount = nmCount   1
                    ReDim Preserve NotMoved(1 To nmCount)
                    NotMoved(nmCount) = fsoFile.Path
                End If
            End If
        Next fsoFile
    Next n
 
    Dim MsgString As String
    MsgString = "Files moved: " & mCount & "(" & mCount   nmCount & ")"
    If nmCount > 0 Then
        MsgString = MsgString & vbLf & vbLf & "Files not moved: " & mCount _
            & "(" & mCount   nmCount & "):" & vbLf & vbLf & Join(NotMoved, vbLf)
    End If
    
    MsgBox MsgString, vbInformation
    
End Sub


Function ArrSubFolderPaths( _
    ByVal InitialFolderPath As String, _
    Optional ByVal ExcludeInitialFolderPath As Boolean = False) _
As String()
    Const ProcName As String = "ArrSubFolderPaths"
    On Error GoTo ClearError
    
    ' Ensure that a string array is passed if an error occurs.
    Dim Arr() As String: Arr = Split("") ' LB = 0 , UB = -1
    
    ' Locate the trailing path separator.
    Dim pSep As String: pSep = Application.PathSeparator
    If Right(InitialFolderPath, 1) <> pSep Then
        InitialFolderPath = InitialFolderPath & pSep
    End If
    
    ' Add the initial folder path to a new collection.
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    Dim coll As Collection: Set coll = New Collection
    coll.Add fso.GetFolder(InitialFolderPath)
    
    ' Add the initial folder path (or don't) to the result.
    Dim n As Long
    If ExcludeInitialFolderPath Then ' don't add
        n = -1
    Else ' add
        ReDim Preserve Arr(0 To 0): Arr(0) = coll(1)
    End If
    
    Dim fsoFolder As Object
    Dim fsoSubFolder As Object
    
    Do While coll.Count > 0
        Set fsoFolder = coll(1)
        coll.Remove 1
        For Each fsoSubFolder In fsoFolder.SubFolders
            coll.Add fsoSubFolder
            n = n   1: ReDim Preserve Arr(0 To n): Arr(n) = fsoSubFolder
        Next fsoSubFolder
    Loop

    ArrSubFolderPaths = Arr

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

CodePudding user response：

This is simple to achieve if you adopt recursive procedure.

Sub Starter()
    Call FilesMover("C:\User\MainFolder\", "C:\User\TEST\")
End Sub

Sub FilesMover(FromPath As String, DestinationPath As String)
    Dim fso As object
    Set fso = CreateObject("scripting.filesystemobject")
    Dim f As File
    Dim d As Folder
    
    ' first move the files in the folder
    For Each f In fso.GetFolder(FromPath).Files
        f.Move DestinationPath
    Next f
    
    ' then check the subfolders
    For Each d In fso.GetFolder(FromPath).SubFolders
        Call FilesMover(d.Path, DestinationPath)
    Next d
End Sub