excelマクロ 冒頭3文字が一致するファイルのコピー移動

excelマクロを作りたいです。
参考になるサイトでも構いません。

前提
(コピー元フォルダ)
が以下のルールで名前付けされた1000件程のword、pafが格納されている
　「数字3桁(スペース)ファイル名」
(移動先フォルダ)
デスクトップ上の「test」フォルダ内に、以下のルールで名前付けされたフォルダが複数入っている
　　「数字3桁(スペース)フォルダ名」


excel B列1行目にコピー元フォルダのフルアドレスを入力(❶)
excel A列3行目以降に、移動先フォルダ名をリスト入力(❷)


マクロを実行すると、❷冒頭3桁が一致することを条件に、❶フォルダのファイルを、❷のフォルダにコピーして配布したい。

よろしくお願いします。

No.1 回答者： 河内のおやじ 回答日時： 2024/02/23 17:46

Sub CopyFiles()

Dim sourceFolder As String
Dim destFolderList As Range
Dim destFolder As Range
Dim sourceFile As String
Dim destPath As String

' コピー元フォルダのパスを取得
sourceFolder = Range("B1").Value

' 移動先フォルダのリストを取得
Set destFolderList = Range("A3:A" & Cells(Rows.Count, "A").End(xlUp).Row)

' 各移動先フォルダについて処理を行う
For Each destFolder In destFolderList
' 移動先フォルダのパスを構築
destPath = ThisWorkbook.Path & "\test\" & destFolder.Value

' 移動先フォルダが存在しない場合は作成する
If Dir(destPath, vbDirectory) = "" Then
MkDir destPath
End If

' コピー元フォルダ内のファイルを取得し、移動先フォルダにコピーする
sourceFile = Dir(sourceFolder & "\*.*")
Do While sourceFile <> ""
' ❷冒頭3桁が一致するかをチェックし、一致する場合はファイルをコピーする
If Left(sourceFile, 3) = Left(destFolder.Value, 3) Then
FileCopy sourceFolder & "\" & sourceFile, destPath & "\" & sourceFile
End If
sourceFile = Dir
Loop
Next destFolder

MsgBox "ファイルのコピーが完了しました。"
End Sub