フォルダを作ってそこに移動

Option Explicit

Dim FSYS 'FileSystem
Dim SHAP 'ShellApplication
Dim CurFolder '移動元のディレクトリ
Dim TargetFolderName '移動先のディレクトリ名
Dim TargetFolder '移動先のディレクトリ
Dim file '
Dim MoveFileName '移動対象のファイル
Const FOF_CREATEPROGRESSDLG = &H0&

Set FSYS = WScript.CreateObject("Scripting.FileSystemObject")
Set CurFolder = FSYS.GetFolder(".")
Set SHAP = WScript.CreateObject("Shell.Application")
’ファイル名からフォルダを作ってそこに移動(jpgのみ)
For Each file In CurFolder.Files
TargetFolderName = FolderName(file.Name)
If TargetFolderName <> vbNull Then
If FSYS.FolderExists(TargetFolderName) = False Then
FSYS.CreateFolder(TargetFolderName)
End If
Set TargetFolder = SHAP.Namespace(CurFolder.Path & "\" & TargetFolderName)
'ワイルドカードを使ってまとめてMove
MoveFileName = CurFolder.Path & "\" & TargetFolderName & "*.jpg"
TargetFolder.MoveHere MoveFileName, FOF_CREATEPROGRESSDLG
End If

Next
Set TargetFolder = Nothing
Set CurFolder = Nothing
Set SHAP = Nothing
Set FSYS = Nothing

Function FolderName(FileName)
Dim objRegExp ' 正規表現オブジェクト
Dim Matches ' 検索結果Collection

Set ObjRegExp = New RegExp
ObjRegExp.Pattern = "_.*\d{3}\.jpg" 'jpg のみ対象　xxxx_999.jpg のパターン
ObjRegExp.IgnoreCase = True
ObjRegExp.Global = False
Set Matches = objRegExp.Execute(FileName)

If Matches.Count > 0 Then
FolderName = objRegExp.Replace(FileName,"")
Else
FolderName = vbNull
End If

Set ObjRegExp = Nothing
Set Matches = Nothing

End Function