VBSで振り分け

Option Explicit

' VBS スクリプトのディレクトリパスを取得
Dim scriptDir
scriptDir = Left(WScript.ScriptFullName, InStrRev(WScript.ScriptFullName, "\"))

' フォルダとname.txtの相対パスを指定
Dim folderPath, nameFilePath
folderPath = scriptDir ' スクリプトと同じディレクトリを指定
nameFilePath = scriptDir & "\name.txt" ' スクリプトと同じディレクトリにあるname.txtを指定

' フォルダ内のファイルを検索して処理
Sub ProcessFilesInFolder(sourceFolder, nameList)
    Dim objFSO, objFileItem
    Set objFSO = CreateObject("Scripting.FileSystemObject")

    ' フォルダ内のファイルを検索して処理
    For Each objFileItem In objFSO.GetFolder(sourceFolder).Files
        Dim fileName, matchName, fileExt
        fileName = objFileItem.Name
        fileExt = objFSO.GetExtensionName(fileName)

        ' ファイル名がname.txtの中の名前と一致または含まれる場合は処理
        For Each matchName In nameList.Keys
            If InStr(1, fileName, matchName, vbTextCompare) > 0 Then
                ' 名前のフォルダが存在しない場合は作成
                Dim destinationFolder
                destinationFolder = objFSO.BuildPath(sourceFolder, matchName)
                If Not objFSO.FolderExists(destinationFolder) Then
                    objFSO.CreateFolder(destinationFolder)
                End If

                ' ファイルを移動
                Dim newFileName, counter
                newFileName = fileName
                counter = 1

                ' 同じ名前のファイルが存在する場合は連番を追加
                Do While objFSO.FileExists(objFSO.BuildPath(destinationFolder, newFileName))
                    ' 拡張子がある場合とない場合で分岐
                    If Len(fileExt) > 0 Then
                        newFileName = Replace(fileName, "." & fileExt, "_" & Format(counter, "00") & "." & fileExt)
                    Else
                        newFileName = Replace(fileName, "", "_" & Format(counter, "00"))
                    End If

                    counter = counter + 1
                Loop

                ' ファイルを移動
                objFSO.MoveFile objFSO.BuildPath(sourceFolder, fileName), objFSO.BuildPath(destinationFolder, newFileName)
                Exit For
            End If
        Next
    Next
End Sub

' name.txtから名前のリストを取得
Dim nameList
Set nameList = CreateObject("Scripting.Dictionary")

Dim objFile, objFSO
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFile = objFSO.OpenTextFile(nameFilePath, 1) ' 1は読み取りモード

Do Until objFile.AtEndOfStream
    Dim name
    name = objFile.ReadLine
    If Not nameList.Exists(name) Then
        nameList.Add name, True
    End If
Loop

objFile.Close

' フォルダ内のファイルを処理
ProcessFilesInFolder folderPath, nameList

WScript.Echo "処理が完了しました。"