対象フォルダ内の各ファイルについて、デリミタ前までの名前でサブフォルダを作ってそこに入れる

moveFileToSubfolder.vbs

Private Const TARGET_DILIMITER = "_ページ"
Private Const MSG_PATH_NG = "対象フォルダに対して本スクリプトを実施できません。"
Private Const MSG_SUBFOLDER_NG = "対象フォルダにサブフォルダがあるときは本スクリプトを実施できません。"

Call main

Sub main()
    Dim baseFolderPath
    Dim FSO
    Dim msg
    
    baseFolderPath = selectForder
    If baseFolderPath = "" Then
        Exit Sub
    End If
    
    If InStr(1, baseFolderPath, "\") = 0 Then
        Call MsgBox(MSG_PATH_NG, vbOKOnly)
        Exit Sub
    End If
    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    If FSO.GetFolder(baseFolderPath).SubFolders.Count > 0 Then
        Call MsgBox(MSG_SUBFOLDER_NG, vbOKOnly)
        Exit Sub
    End If
    
    msg = getStartMsg(baseFolderPath)
     
    If MsgBox(msg, vbYesNo + vbCritical + vbDefaultButton2) = vbNo Then
        Exit Sub
    End If
    
    Call filesToFolders(baseFolderPath)
    
    Call MsgBox("ファイル移動が完了しました。", vbInformation)
    
    Set FSO = Nothing
End Sub
 
Private Function getStartMsg(baseFolderPath)
    Dim msg
    
    msg = "本スクリプトのフォルダにあるファイルをデリミタ"
    msg = msg & "(" & TARGET_DILIMITER & ")"
    msg = msg & "に基づいてフォルダを作成、移動します。"
    msg = msg & vbCrLf & "本当によろしいですか？ "
    msg = msg & "（この操作は取り消しできません）"
    msg = msg & vbCrLf & vbCrLf & baseFolderPath
    getStartMsg = msg
End Function

Private Function selectForder()
    Dim objShell
    Dim objFolder
    
    Set objShell = CreateObject("Shell.Application")
    Set objFolder = objShell.BrowseForFolder(0, "対象のフォルダを選択してください。", 0)
    
    selectForder = ""
    If Not objFolder Is Nothing Then
        selectForder = objFolder.Items.Item.Path
    End If
    
    Set objShell = Nothing
    Set objFolder = Nothing
End Function


Private Sub filesToFolders(baseFolderPath)
    Dim FSO
    Dim tempFile
    Dim tempFolderName
    Dim tempForderFullName

    
    Set FSO = CreateObject("Scripting.FileSystemObject")

    For Each tempFile In FSO.GetFolder(baseFolderPath).Files
        
        If InStr(1, tempFile.Name, TARGET_DILIMITER) > 0 Then
        
            'デリミタより前を取り出す
            tempFolderName = Left(tempFile.Name, InStr(1, tempFile.Name, TARGET_DILIMITER) - 1)
    
            If tempFolderName <> "" Then
            
                tempForderFullName = baseFolderPath & "\" & tempFolderName
            
                'フォルダがなければ
                If Not FSO.FolderExists(tempForderFullName) Then
        
                    'フォルダ作成
                    FSO.CreateFolder (tempForderFullName)
                    
                End If
                
                '作成済みのフォルダへ移動
                tempFile.Move (tempForderFullName & "\" & tempFile.Name)
            
            End If
        End If
    Next

    Set FSO = Nothing
    Set tempFile = Nothing
End Sub