ファイルの整理 バッチファイルの作成_2

質問

フォルダ内にある
複数のフォルダ内に点在する
5000個のファイルのうち

エクセルに書かれた1000項目のファイルを取り出し違うフォルダに移したいのですが
現在一つ一つ手作業で、移動させています。

フォルダ構成を守りながら

さくっと移動作業が終わらせれる
コマンドプロントや、バッチファイルあるいはそういうことができるツールなどあれば
ご教授お願いできないでしょうか？

作業としては、単純なのですが、１日つぶしてしまい、時間をもったいなく感じております。

よろしくお願い致します

回答No.2

NotFound404

極力早い処理をと思いつつもこの辺が私の限界です。
★★の所はそちらの環境に応じて変更要
Excelの標準モジュールで（main）マクロをお試しを。多分20分～一時間程度掛かります。
汚いコードですみません。
投稿用にTABインデントを全角スペースに変換しています
エラーが発生した場合は
エラーになった行とエラーメッセージをお知らせください。

Sub main()
On Error GoTo errH
Const TrgDir As String = "e:\tmp" '←★★ここを元のフォルダ名に
　　Dim newDir As String
　　Dim ofs As Object
　　Dim c As Range
　　newDir = TrgDir & "_New"

　　Set ofs = CreateObject("Scripting.FileSystemObject")
　　newDir = TrgDir & "_New"

　　If ofs.folderexists(TrgDir & "_New") = False Then
　　　　ofs.CreateFolder TrgDir & "_New"
　　End If

　　Call makeDir(TrgDir, TrgDir, newDir)

Dim FileDics As Object, Pathdics As Object
Dim FileKey As Variant, PathKey As Variant
　　Set FileDics = CreateObject("Scripting.Dictionary")

　　Set Pathdics = CreateObject("Scripting.Dictionary")
　　Call makePathdics(Pathdics, TrgDir)
　　For Each PathKey In Pathdics.Keys
　　　Debug.Print PathKey, Pathdics.Item(PathKey)
　　Next

Dim Found As Boolean
Dim j As Long
Dim cv As String

　　For Each c In Sheets("sheet1").Range("A1", Range("A1").End(xlDown))
　　　c.Select
　　　cv = c.Value
　　　Found = False
　　　　For Each PathKey In Pathdics.Keys
　　　　　　j = j + 1
　　　　　　DoEvents
　　　　　　Debug.Print c.Row, j
　　　　　　If cv = Pathdics.Item(PathKey) Then
　　　　　　　　ofs.copyfile PathKey, Replace(PathKey, TrgDir, newDir, compare:=vbTextCompare)
　　　　　　　　Found = True
　　　　　　End If
　　　　Next PathKey
　　　　If Found = False Then
　　　　　c.Offset(0, 1).Value = "NotFound"
　　　　End If
　　Next c

Call delDir(newDir)

　　Set ofs = Nothing
beep:　　beep
MsgBox "おしまい"
Exit Sub
errH:
　　　　　c.Offset(0, 1).Value = "Error" & Err.Description
　　　　　Resume Next
End Sub

Private Sub makeDir(TrgDir As String, BaseDir As String, newDir As String)
　　Dim ofs As Object
　　Dim objDir As Object

　　Set ofs = CreateObject("Scripting.FileSystemObject")
　　Set objDir = ofs.getfolder(TrgDir)

　　For Each objDir In objDir.SubFolders
　　　　Debug.Print objDir.Path, TrgDir, newDir
　　　　ofs.CreateFolder Replace(objDir.Path, BaseDir, newDir, compare:=vbTextCompare)
　　　　Call makeDir(objDir.Path, BaseDir, newDir)
　　Next

　　Set objDir = Nothing: Set ofs = Nothing
End Sub

Private Sub delDir(ByVal newDir As String)
'空のフォルダの削除
　　Dim ofs As Object
　　Dim objDirSub As Object, objDir As Object
　　Set ofs = CreateObject("Scripting.FileSystemObject")
　　Set objDir = ofs.getfolder(newDir)

　　For Each objDirSub In objDir.SubFolders
　　　　Debug.Print objDirSub.Path
　　　　Call delDir(objDirSub.Path)
　　Next

　　If objDir.Files.Count = 0 And objDir.SubFolders.Count = 0 Then
　　　　ofs.deletefolder objDir
　　End If
End Sub

Private Function makePathdics(ByRef Pathdics As Object, ByVal TergetFolder As String)
　　Dim oFile　 As Object
　　Dim oFolder　As Object
　　Dim oFolders As Object
　　Dim ofs　　 As Object

　　Set ofs = CreateObject("Scripting.FileSystemObject")

　　For Each oFile In ofs.getfolder(TergetFolder).Files
　　　　Pathdics.Add oFile, oFile.Name
　　Next

　　Set oFolders = ofs.getfolder(TergetFolder)
　　For Each oFolder In oFolders.SubFolders
　　　　Call makePathdics(Pathdics, oFolder.Path)
　　Next

End Function

お礼

すみません、すごく長く丁寧にプログラミングを書いていただき
ありがとう御座います。

自分はプログラミングの知識はほぼ皆無に等しいので

自分が過去に質問した、

『ファイルの整理　バッチファイルの作成』

みたいな感じで、初心者にも優しい感じで

作るのは、やることが複雑すぎて不可能でしょうか？