各シートの指定したセルの値に従ってシートを分割してファイルに振り分けるマクロ

複数のシートの指定したセル（この場合はB5の所属）に従って

１つのファイルの中の複数シートを

所属ごとのファイルにコピーして振り分けるマクロ

コード

Sub シート振り分け()
    Dim SourceWB As Workbook
    Dim listsheet As Worksheet
    Dim CopyWB As Workbook
    Dim r As Long
    Dim i As Long
    Dim response As VbMsgBoxResult
    
    ' 余計なフォルダがないか確認
    response = MsgBox("フォルダに他のファイルがないことを確認しましたか？", vbYesNo + vbQuestion)
    
    ' 確認していない場合は終了
    If response = vbNo Then
        MsgBox "作業を終了します。", vbExclamation, "作業終了"
        Exit Sub
    End If
    
    '画面の更新をしない
    Application.ScreenUpdating = False
    
    'コピー元のブックを設定する
    Set SourceWB = ThisWorkbook
    
    'リストを作って重複削除マクロを実行
    Call リストを作って重複削除
    
    'アクティブシートをリストシートに設定
    Set listsheet = ActiveSheet

    '確認ダイアログを表示しないように設定
    Application.DisplayAlerts = False
    
    '変数rを設定
    r = 1
    
    '繰り返し処理
    Do While listsheet.Cells(r, 1) <> ""
            'コピー先ブックを追加する
            Set CopyWB = Workbooks.Add
            
            With SourceWB
            ' ２枚目以降の各シートに対して処理
            For i = 2 To .Sheets.Count
                '各シートのB5がリストと同じだった場合に処理
                If .Sheets(i).Range("B5") = listsheet.Cells(r, 1) Then
                    ' コピー元ワークシートをコピー先ブックにコピー
                    .Sheets(i).Copy After:=CopyWB.Sheets(CopyWB.Sheets.Count)
                End If
            Next i
            End With
            'いらないシートを削除
            CopyWB.Sheets(1).Delete
            'ブックを保存
            CopyWB.SaveAs ThisWorkbook.Path & "\" & listsheet.Cells(r, 1) & ".xlsx"
            CopyWB.Close savechanges:=False
            r = r + 1
    Loop
    
    'リストシートを削除
    listsheet.Delete
    
    '確認ダイアログの設定を元に戻す
    Application.DisplayAlerts = True
    
    MsgBox "シート振り分け完了"
    
End Sub

Sub リストを作って重複削除()
    Dim listsheet As Worksheet
    Dim i As Long
    Dim ii As Long
    
    'リスト用のシートを追加
    Set listsheet = Worksheets.Add(before:=Sheets(1))
    listsheet.name = "リスト"
    
        'リストシート以外を処理
        For i = 2 To Sheets.Count
        
            '各シートのB5の値をリストシートに入力
            listsheet.Cells(i - 1, 1) = Sheets(i).Range("B5")
        
        Next i
        
    'リストシートの重複を削除
    listsheet.Range("A1").CurrentRegion.RemoveDuplicates Columns:=1
    
    'リストシートをアクティブに
    listsheet.Select
End Sub

注意点

• フォルダ内にすでに同名のファイルがある場合は勝手に上書きされる。フォルダの中に他のファイルを置かないこと。念のため最初に確認を促すコードにしている。