CODEWITHSUNDEEP
excelvba
Jeremy Wong
Jeremy Wong

Reputation: 31

Move files from multiple folders to a single folder

I am trying to consolidate Excel files from different folders to a single folder. Within each folder there is a single Excel file.

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 unable to get the files from the subfolder within the folder (as shown in the image).

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

Multiple Folders, One Excel file per Folder
enter image description here

Upvotes: 3

Views: 874

Answers (2)

Rosetta
Rosetta

Reputation: 2725

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

Upvotes: 1

VBasic2008
VBasic2008

Reputation: 54777

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

Upvotes: 2

Related Questions