複数のファイルを特定のフォルダに移動するExcel VBAコード

Question

1つのフォルダから別のフォルダに移動する必要があるファイルが100,000を超えています（.PDFおよび.XLS）。私は、私が作業している3つのことがあります：ソースフォルダ（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機能は、文字「A」（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を展開する方法は、I他の場所で見たことがありますが、私はなぜ機能がそれが言っていることをやり遂げることができないのか分かりません。もし私がそれを必要としないなら、私はしなかった。

しかし私の勇気は、彼の考えに同意するが、手順をさらにスピードアップするためにジョシュアの提案を取り上げるまでは行っていない。ワークシートの100,000回のアクセスを避けると、多くの時間を節約できます。代わりに、ステータスバー（左下）に進行状況表示を追加して、あなたを待っている間あなたを守ります：

パスは現在、メイン手順の下にあるTestPathsに設定されています。