Move files from multiple folders to a single folder - excel

Question

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

Answer 1

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

Answer 2

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