フォルダに一括でファイル振り分けるマクロについて

お世話になっております。
マクロ初心者です。

ファイル名称のyyyymmddとフォルダ名称のyyyymmddが
一致したものだけを移動させるVBAを教えていただきたいです。

ファイル名称の左から14文字目～22文字目のyyyymmddとフォルダ名称の左から1文字目～8文字目の
yyyymmddが一致する場合のみ該当のファイルをフォルダへ移動します。
一致しないものはそのままにします。
フォルダとファイルは複数存在します。
因みに今回移動させるファイルはAVIファイルです。

ファイル名称「xx-xx__0000x_yyyymmddxxxxxx.avi」
フォルダ名称「yyyymmdd_xx-xx_aaaaa」

例)
ファイル名称
1 xx-xx__0000x_20211001xxxxxx.avi
2 xx-xx__0000x_20211002xxxxxx.avi
3 xx-xx__0000x_20211003xxxxxx.avi
4 xx-xx__0000x_20210901xxxxxx.avi
フォルダ名称
A 20211001_xx-xx_aaaaa
B 20211002_xx-xx_aaaaa
C 20211003_xx-xx_aaaaa

１は20211001が一致するためAへ移動
２は20211002が一致するためBへ移動
３は20211003が一致するためCへ移動
４は20210901が一致するフォルダがないためそのまま

以上です。
よろしくお願いします。

質問者からの補足コメント

• 説明不足ですみません。
  
  フォルダーとファイルは同じ階層にあり、
  フォルダーに権限等は設定していません。

    補足日時：2021/11/01 07:00

No.2 ベストアンサー 回答者： tatsumaru77 回答日時： 2021/11/01 18:37

以下のマクロを標準モジュールに登録してください。

Const FolderName As String = "d:\goo\data3"
は移動対象となるファイル及びフォルダを格納しているフォルダ名です。
あなたの環境にあわせて適切に設定してください。

--------------------------------------------
Option Explicit
Public Sub ファイル移動()
Const FolderName As String = "d:\goo\data3"
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Dim tfolders As Object
Dim tfiles As Object
Dim wfil As Object
Dim wfol As Object
Dim srcName As String
Dim dstName As String
Set tfolders = FSO.getfolder(FolderName).Subfolders
Set tfiles = FSO.getfolder(FolderName).Files
For Each wfil In tfiles
For Each wfol In tfolders
If Mid(wfil.Name, 14, 8) = Mid(wfol.Name, 1, 8) Then
srcName = FolderName & "\" & wfil.Name
dstName = FolderName & "\" & wfol.Name & "\" & wfil.Name
If FSO.FileExists(dstName) Then
FSO.deletefile (dstName)
End If
FSO.movefile srcName, dstName
Exit For
End If
Next
Next
MsgBox ("完了")
End Sub

この回答へのお礼

お世話になります。

早速ご返信いただき、誠にありがとうございます。

確認してみます。

お礼日時：2021/11/01 21:13

No.1 回答者： めぐみん_ 回答日時： 2021/10/31 22:04

ファイルが保存されているフォルダと振り分けるフォルダの相対位置関係が不明ですし、場所によっては権限で移動できないかも？

比較する場合は文字列から抜き出すためにＭＩＤ関数
http://officetanaka.net/excel/vba/function/Mid.htm
を用いてみるとか？

あとはFileSystemObject
http://officetanaka.net/excel/vba/filesystemobje …
を読破するといけるかな？

この回答へのお礼

早速ご返信いただき、誠にありがとうございます。

記載されたサイトにアクセスして勉強してみます。

お礼日時：2021/11/01 07:06