Question

我有超过100,000个文件（.PDF和一些.XLS）需要从一个文件夹移动到另一个文件夹。我有三件事我正在使用：源文件夹（A），目标文件夹（B）和说明文件应该去的位置的Excel文档。

文件夹A：100,000多个文件

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

Excel文件：B列列出文件名称。 C列列出了要进入“文件夹B”的目的地。

我需要根据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 Documents\A\"
    ' This is the address of your folder "B", must end on a path separator:
    Const TargetPath As String = "C:\My Documents\B\"

    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）。这导致我添加了一个Messagebox下面的新代码也会在文件夹“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 Documents\A"
    ' This is the address of your folder "B":
    Const TargetPath As String = "C:\My Documents\B"

    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中，您可以在主程序下找到它。

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

1 个答案: