excel - 将文件从多个文件夹移动到单个文件夹

Question

我正在尝试将不同文件夹中的 Excel 文件合并到一个文件夹中。每个文件夹中都有一个 Excel 文件。

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

代码无法从文件夹内的子文件夹中获取文件(如图所示)。

我要更改的区域是“FromPath”，是否可以包含通配符以指定子文件夹？

多个文件夹，每个文件夹一个Excel文件

Answer 1

将文件从多个文件夹移动到单个文件夹(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