将多个文件夹中的文件移动到单个文件夹。

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文件

- Jeremy Wong

---

这个链接可以帮助你遍历文件夹和子文件夹。只需将其调整为仅移动Excel文件即可。 - Foxfire And Burns And Burns

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

- VBasic2008

---

非常感谢！这段代码起作用了，并且它帮助我们复制了子文件夹中的所有Excel文件。我们能否微调一下代码，只抓取名为“DPP General Template Day X Block A.xlsx”的特定文件？其中Day X根据文件夹日期而变化。例如，“13.11.2021”文件夹对应“Day 13”。 - Jeremy Wong

在 If LCase... Then 行之后，添加另一个 If 语句：If Instr(1, fsoFile.Name, "DPP General Template Day", vbTextCompare) = 1 Then（即以...开头）。别忘了 'closing' 的 End If。 - VBasic2008

Answer 2

如果您采用递归过程，那么这很容易实现。

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

- Rosetta

---

这个可以用！非常感谢！但是您能否建议我们如何进一步编辑代码以移动特定的Excel文件吗？在文件夹中有多个Excel文件，我只想移动一个单独的文件。假设文件名为“DPP General Template Day X Block A.xlsx”？其中Day X根据文件夹日期而变化。例如，“13.11.2021”文件夹的Day 13。 - Jeremy Wong

@JeremyWong，您可以使用 If..Else..End If 条件语句来有条件地移动文件。您可以参考此文档 https://learn.microsoft.com/en-us/office/vba/language/concepts/getting-started/using-ifthenelse-statements。文件名可以通过 f.name 获取。 - Rosetta