Excel VBA代码，将多个文件移至特定文件夹

Question

我有超过100,000个文件（.pdf和几个.xl），需要从一个文件夹移动到另一个文件夹。我有三件事：源文件夹（a），目标文件夹（b）和excel文档说明文件应在哪里。

文件夹A：100,000 文件

文件夹B：100个文件夹已经预先命名

excel文件：B列列出了文档名称。C列列出了目的地的目的地。

我需要根据Excel文档根据其特定位置移动所有文件。我已经看到有关移动文件的一些代码；但是，这更复杂。任何帮助，将不胜感激。

Answer 1

这是应该完成工作的代码。但是，我担心硬盘是否可以跟上VBA的速度。因此，将DoEvents插入每个循环中。坦白说，我不知道那是正确的治疗方法。

Sub MoveFiles()
    ' 01 Oct 2017
    ' This is the address of your folder "A", must end on a path separator:
    Const SourcePath As String = "C:My DocumentsA"
    ' This is the address of your folder "B", must end on a path separator:
    Const TargetPath As String = "C:My DocumentsB"
    Dim Fn As String                        ' file name
    Dim Fold As String                      ' folder name in "B"
    Dim R As Long                           ' row counter
    With ActiveSheet
        ' start in row 2, presuming 1 to have captions:
        For R = 2 To .Cells(.Rows.Count, "B").End(xlUp).Row
            Fn = Trim(.Cells(R, "B").Value)
            Fold = Trim(.Cells(R, "C").Value)
'            Debug.Print SourcePath & Fn & " = " & TargetPath & Fold & "" & Fn
            Name SourcePath & Fn As TargetPath & Fold & "" & Fn
            DoEvents
        Next R
    End With
End Sub

我在具有380个文件的文件夹上测试了上述代码，发现Name函数拒绝了包含字符"ä"的文件名（Chr（0228）。这导致我添加了一个消息框，失败的情况。下面的新代码还可以在文件夹" b"中创建和目录。我这样做是为了节省设置所有子文件夹的时间，您也可以。

Option Explicit
Sub MoveFiles()
    ' 02 Oct 2017
    Dim Src As String                       ' source path
    Dim Dest As String                      ' Target path
    Dim Fn As String                        ' file name
    Dim Fold As String                      ' folder name in "B"
    Dim Rl As Long                          ' last row in column B
    Dim R As Long                           ' row counter
    With ActiveSheet
        If TestPaths(Src, Dest) Then
            Rl = .Cells(.Rows.Count, "B").End(xlUp).Row
    '        ' start in row 2, presuming 1 to have captions:
            For R = 2 To Rl
                Fn = Trim(.Cells(R, "B").Value)
                Fold = Dest & Trim(.Cells(R, "C").Value)
                If FolderName(Fold, True) Then
                    On Error Resume Next
        '            Debug.Print R, Src & Fn & " = " & Fold & "" & Fn
                    Name Src & Fn As Fold & Fn
                    If Err Then
                        MsgBox "File " & Fn & vbCr & _
                               "in row " & R & " couldn't be moved." & vbCr & _
                               "Error " & Err & " - " & Err.Description
                    End If
                End If
    '            DoEvents
                If (Rl - R) Mod 50 = 0 Then Application.StatusBar = Rl - R & " records remaining"
            Next R
        End If
    End With
End Sub
Private Function TestPaths(Src As String, _
                           Dest As String) As Boolean
    ' 02 Oct 2017
    ' both arguments are return strings
    ' This is the address of your folder "A":
    Const SourcePath As String = "C:My DocumentsA"
    ' This is the address of your folder "B":
    Const TargetPath As String = "C:My DocumentsB"
    Dim Fn As String
    Src = SourcePath
    If FolderName(Src, False) Then
        Dest = TargetPath
        TestPaths = FolderName(Dest, True)
    End If
End Function
Private Function FolderName(Ffn As String, _
                            CreateIfMissing As Boolean) As Boolean
    ' 02 Oct 2017
    ' Ffn is a return string
    Dim Sp() As String
    Dim i As Long
    Ffn = Trim(Ffn)
    Do While Right(Ffn, 1) = ""
        Ffn = Left(Ffn, Len(Ffn) - 1)
    Loop
    Sp = Split(Ffn, "")
    Ffn = ""
    For i = 0 To UBound(Sp)
        Ffn = Ffn & Sp(i) & ""
        On Error Resume Next
        If Len(Dir(Ffn, vbDirectory)) = 0 Then
            If Err Then
                MsgBox Err.Description & vbCr & _
                "Error No. " & Err, vbCritical, "Fatal error"
                Exit Function
            Else
                If CreateIfMissing Then
                    MkDir Ffn
                Else
                    MsgBox "The given path doesn't exist:" & vbCr & _
                           Ffn, vbCritical, "Set-up error"
                    Exit Function
                End If
            End If
        End If
    Next i
    FolderName = (i > 0)
End Function

我在没有DoEvents的情况下进行了测试。按照@Joshua Fenner建议，部署DoEvents的方法是我在其他地方见过的方法，但是我不明白为什么该函数不能只做所说的事情。如果我不需要，也不需要。

但是，尽管我同意他的想法，但我的勇气并没有采取约书亚的建议进一步加快程序。避免使用100,000个工作表的访问将节省大量时间。相反，我在状态栏（左下）中添加了一个进度显示，以便在您等待时保持您的公司：

请注意，路径现在设置在函数TestPaths中，您将在主过程下方找到。