'

Sub test()
 Dim folder1 As String
 Dim folder2 As String
 Dim files As New Collection
 Dim file As Variant
 Dim folder As String
 Dim f As String
 Dim dr As String
 folder1 = "C:\Users\coco\Desktop\アスベスト\1_A_AL\" '移動するExcelファイルのフォルダ(最後が\)
folder2 = "C:\Users\coco\Desktop\アスベスト\2_B_17\" '保存先のExcelフォルダのフォルダ(最後が\)
 'まずExcelファイルを取得
file = Dir(folder1 & "*.xlsx") '最初のxlsxファイル
Do While file <> "" 'ファイルがある間
files.Add file '記憶
file = Dir
 Loop
 '振り分け
For Each file In files '覚えているファイルを順に
f = file 'ファイル名
If Left(f, 3) = "Blank" Then 'ファイル名の中に"abc"があれば
folder = Dir(folder2 & "*" & Mid(f, 4, 6), vbDirectory) 'ファイル名の左から4つ目から6つの文字列が、フォルダ名と同じフォルダを検索
If folder <> "" Then Name folder1 & file As folder2 & folder & "\" & file 'フォルダがあれば移動
End If
 Next
 Set files = Nothing '後始末
End Sub