ファイル名と同じ名前のフォルダを作ってファイルを格納するマクロ

マクロが入ってるエクセルと同じフォルダのエクセルと

同じ名前のフォルダを作って

ファイルを格納するマクロ

コード

Sub ファイル名のフォルダを作って格納()
    Dim Path As String
    Dim FileName As String
    Dim FolderName As String
    
    'フォルダのパスを取得
    Path = ThisWorkbook.Path & "\"
   
    'フォルダの中で拡張子が.xlsxのファイルを取得
    FileName = Dir(Path & "*.xlsx")
    
    '繰り返し処理
    Do While FileName <> ""
     
        '拡張子.xlsxを削除したフォルダ名を作成
        FolderName = Left(FileName, Len(FileName) - 5)
        'フォルダを作成
        MkDir Path & FolderName
        'ファイルを移動
        Name Path & FileName As Path & FolderName & "\" & FileName

    '次のファイルを取得
    FileName = Dir

    Loop
    
    MsgBox "格納完了"
    
End Sub

注意点

すでに同じ名前のフォルダがあるとエラーになる