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

我有超过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个文件的文件夹上testing了上面的代码，除了Name函数拒绝包含字符“ä”（Chr（0228））的文件名之外，没有发现任何问题，这导致我添加了一个MessageBox， 。下面的新代码也创build和目录在文件夹“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 

我没有DoEventstesting。 按照@Joshua Fenner的build议部署DoEvents的方法是我在别处看到的方法，但是我不明白为什么这个函数不能完成它所说的工作。 如果我不需要它，那就更好了，而我却没有。

不过，我的勇气并没有达到约书亚提出的进一步加快程序的build议，尽pipe我同意他的想法。 避免100,000次访问工作表会节省大量的时间。 相反，我在状态栏中添加了一个进度显示（左下angular），以便在等待的时候保持联系.-)

请注意，path现在被设置在TestPaths函数中，您将在主程序的下面find它。