複数フォルダ・複数ファイルの一括移動

質問

(A)のように、C:\AAAA\BBBBB\2021年\データ\1月フォルダに支店社員・支店顧客のエクセルファイルと支店社員IDxxxのワードファイルがあり、さらにフォルダ各顧客の中に支店顧客IDxxxのワードファイルがあります。
これを移動させ、(B)ように、C:\AAAA\BBBBB\2021年1月フォルダの下に、社員データフォルダと顧客データフォルダに分けて配置したいです。
手動で一つずつではなく自動で処理する方法はありますでしょうか。
コマンドプロンプト・パワーシェル・VBA・VBS・WSFなどが使用できる環境です。よろしくお願いします。

(A)
C:\AAAA\BBBBB\2021年\データ
├─1月
│ │ 支店社員.xlsx
│ │ 支店顧客.xlsx
│ │ 支店社員ID001.docx
│ │
│ └─各顧客
│ 支店顧客ID001.docx
│ 支店顧客ID002.docx
│
├─(2月～11月も同様)
│
└──12月
　 │ 支店社員.xlsx
　 │ 支店顧客.xlsx
　 │ 支店社員ID004.docx
　 │ 支店社員ID006.docx
　 │
　 └─各顧客
　 支店顧客ID004.docx
　 支店顧客ID005.docx

(B)
C:\AAAA\BBBBB\2021年
├─1月
│ ├─社員データ
│ │ 支店社員.xlsx
│ │ 支店社員ID001.docx
│ │
│ └─顧客データ
│ 支店顧客.xlsx
│ 支店顧客ID001.docx
│ 支店顧客ID002.docx
│
├─(2月～11月も同様)
│
└─12月
　 ├─支店データ
　 │ 支店社員.xlsx
　 │ 支店社員ID004.docx
　 │ 支店社員ID006.docx
　 │
　 └─顧客データ
　 支店顧客.xlsx
　 支店顧客ID004.docx
　 支店顧客ID005.docx
　 支店顧客ID007.docx

回答No.2

HohoPapa · ベストアンサー

ファイル名の先頭4文字が"支店社員"なのか、"支店顧客"なのかで
移動先のフォルダーを決めるということでいいですね？

また、例示された移動先の1月は
　─1月
　　├─社員データ
　　└─顧客データ

他方、12月は
　─12月
　　├─支店データ
　　└─顧客データ

と不一致です。
つまり、前者は社員データで、後者は支店データです。
後者を前提にしました。

更に、移動先の
　─12月
　　├─支店データ
　　└─顧客データ
これらのフォルダーはすでに作成されている前提としました。

複写のログをマクロブックのアクティブなシートに書き出しています。
マクロ実行中に異常が起きた場合に備え、移動ではなく複写にしました。
詳しくはコードを読んでください。

以下がサンプルなコードです。

Option Explicit

Const GetDir = "C:\AAAA\BBBBB\2021年\データ"
Const PutDir = "C:\AAAA\BBBBB\2021年"

Dim FileCounter As Long

Sub sample()
　FileCounter = 0
　Cells.ClearContents
　GetFileName GetDir
End Sub

'//---全てのフォルダー内のファイルを総当たり
Sub GetFileName(strPath As String)

　Dim tSfo As Object
　Dim tGf As Object
　Dim tFi As Object
　Dim tSub As Object
　Dim MyM As String '月
　Dim PutPath As String
　Dim SubDir As String

　Set tSfo = CreateObject("Scripting.FileSystemObject")
　Set tGf = tSfo.GetFolder(strPath)

　For Each tFi In tGf.Files
　　SubDir = ""
　　MyM = ""
　　If Right(strPath, 5) = "月\各顧客" And Left(Right(strPath, 7), 1) = "\" Then
　　　MyM = Left(Right(strPath, 6), 1)
　　End If
　　If Right(strPath, 5) = "月\各顧客" And Left(Right(strPath, 8), 1) = "\" Then
　　　MyM = Left(Right(strPath, 7), 2)
　　End If
　　If Right(strPath, 1) = "月" And Left(Right(strPath, 3), 1) = "\" Then
　　　MyM = Left(Right(strPath, 2), 1)
　　End If
　　If Right(strPath, 1) = "月" And Left(Right(strPath, 4), 1) = "\" Then
　　　MyM = Left(Right(strPath, 3), 2)
　　End If

　　If Left(tFi.Name, 4) = "支店社員" Then
　　　SubDir = "月\支店データ"
　　End If
　　If Left(tFi.Name, 4) = "支店顧客" Then
　　　SubDir = "月\顧客データ"
　　End If

　　FileCounter = FileCounter + 1
　　PutPath = PutDir & "\" & MyM & SubDir & "\" & tFi.Name
　　Cells(FileCounter, 1).Value = strPath & "\" & tFi.Name
　　If ((MyM <> "") And (SubDir <> "")) Then
　　　Cells(FileCounter, 2).Value = PutPath
　　　FileCopy strPath & "\" & tFi.Name, PutPath
　　Else
　　　Cells(FileCounter, 2).Value = "複写対象外"
　　End If

　Next

　For Each tSub In tGf.SubFolders
　　GetFileName tSub.Path　'再帰処理
　Next

End Sub

お礼

詳しくありがとうございます。移動先にフォルダを分けて格納することができました。独力ではとてもできませんでした。ありがとうございます。

回答No.3

SI299792

済みません。図を見間違い、
各顧客にあるものを顧客データに移し、
その上にあるものを、社員データに移せばいいと思っていました。
私のプログラムは使えません。無視して下さい。

本当に削除できないのは不便だ。

お礼

ご丁寧にありがとうございます。

回答No.1

SI299792

Excel VBA でいいですか。
フォルダの移動だけを行います。中のファイル名はチェックしません。
画像の様に、親・変更前・変更後フォルダ名を入力して下さい。
Option Explicit
'
Sub Macro1()
　　Dim FSO As Object
　　Dim Path As Object
　　Dim RInp As Long
　　Dim InpPath As String
　　Dim OutPath As String
'
　　Set FSO = CreateObject("Scripting.FileSystemObject")
'
　　For Each Path In FSO.GetFolder([B1]).SubFolders
'
　　　　For RInp = 2 To Cells(Rows.Count, "C").End(xlUp).Row
　　　　　　InpPath = Path & Cells(RInp, "B")
　　　　　　OutPath = Path & Cells(RInp, "C")
　　　　　　On Error Resume Next
　　　　　　MkDir OutPath
　　　　　　FSO.MoveFile InpPath & "\*.*", OutPath
　　　　　　RmDir InpPath
　　　　　　On Error GoTo 0
　　Next RInp, Path
End Sub

お礼

移動先のフォルダを作成する方法、移動の際にワイルドカードを使う方法など、詳しくありがとうございます。Cellsで列指定にアルファベットが使えることも初めて知りました。今後活用します。ありがとうございます。