ファイル名を一括変換して、部署ごとのフォルダを作って振り分けて格納するマクロ

バラバラの名前で様々な部署から提出されたファイルを

ファイルの中のセルの値に従ってファイル名を変更して

フォルダごとに分けて




格納するマクロ

コード

Sub ファイル名変換とフォルダ作成と格納()
    Dim Path As String
    Dim FileName As String
    Dim NewfileName As String
    Dim ListSheet As Worksheet
    Dim i As Long
    Dim FolderName As String
    Dim ii As Long
    
    Application.ScreenUpdating = False
    'マクロエクセルが保存されているフォルダのパスを取得
    Path = ThisWorkbook.Path & "\"
    'リストワークシートを作成
    Set ListSheet = Worksheets.Add
    
    'フォルダの中で拡張子がxlsxのファイルを取得
    FileName = Dir(Path & "*.xlsx")
    i = 1
     
    '繰り返し処理
    Do While FileName <> ""
       
        'フォルダ内のエクセルを開く
        Workbooks.Open Path & FileName
        '新しいファイル名を指定
        NewfileName = Range("B5") & "_" & Range("B6") & ".xlsx"
        'フォルダ名にしたい値をリストシートへ入力
        ListSheet.Cells(i, 1) = Range("B5")
        'ファイルを閉じる
        ActiveWorkbook.Close
        '新しいファイル名に変更
        Name Path & FileName As Path & NewfileName
        'ファイルを再取得
        FileName = Dir
        i = i + 1
        
    '繰り返し
    Loop
    
    'リストシートの重複を削除
    ListSheet.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1
    'リストシートを選択
    ListSheet.Select
    'フォルダ作成マクロの実行
    Call フォルダ作成
    'フォルダ分けマクロの実行
    Call フォルダ分け
    
    'アラートを消す
    Application.DisplayAlerts = False
    'リストシートを削除
    ListSheet.Delete
    'アラートを戻す
    Application.DisplayAlerts = True
    MsgBox "ファイル名変換・フォルダ作成・格納完了"

End Sub

Sub フォルダ作成()
    Dim ii As Long
    Dim FolderName As String
    Dim temp As String
    
    ii = 1
    Do While Cells(ii, 1) <> ""
        'フォルダ名を指定
        FolderName = ActiveSheet.Cells(ii, 1)
        '同名のフォルダがあるか検索
        temp = Dir(ThisWorkbook.Path & "\" & FolderName, vbDirectory)
        '同名のフォルダがない場合
        If Len(temp) = 0 Then
            'フォルダを作成
            MkDir ThisWorkbook.Path & "\" & FolderName
        End If
        ii = ii + 1
    Loop
    
End Sub
Sub フォルダ分け()
    Dim Path As String
    Dim FileName As String
    Dim FolderName As String
    
    'フォルダのパスを取得
    Path = ThisWorkbook.Path & "\"
   
    'フォルダの中で拡張子が.xlsxのファイルを取得
    FileName = Dir(Path & "*.xlsx")
    
    '繰り返し処理
    Do While FileName <> ""
     
        'ファイル名の_から左を振り分け先のフォルダ名とする
        FolderName = Left(FileName, InStr(FileName, "_") - 1)
        'ファイルを移動
        Name Path & FileName As Path & FolderName & "\" & FileName

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

    Loop
    
End Sub

注意点

• 参照するセルは任意のものに変更する
• そもそも部署名が間違えていたり、省略して書かれていると誤ったフォルダに振られる。正しく振られてているか目視で確認すること
• 同じ名前のフォルダがあるか確認して同名のフォルダがない場合に五月雨式に提出された場合も対応できるようになってるはず。