Excel VBA フィルタしてフィルタ値毎にファイル分割する

##はじめに
　Excelで作成された表に対して、ファイルを分割したいケース
　たとえば売上台帳みたいな表で、店舗ごとにファイルを分割するなどのマクロ

##コード

Sub フィルタしてフィルタ値毎にファイル分割する()
'Ｂ列でフィルタして、それぞれの値ごとにブックを作成して保存する。
'ファイル名はフィルタ値とし、カレントブックと同一フォルダに保存する。

On Error GoTo Error
    
    '描画止める
    Application.ScreenUpdating = False
    '確認メッセージ非表示
    Application.DisplayAlerts = False
    
    Dim stRow As Integer  '基準点　行
    Dim stCo  As Integer  '基準点　列
    Dim MySheetname As String   'カレントシート名
    Dim TempSheetname As String 'フィルタ値の貼り付け用
    Dim FilName As String   'フィルタ実施時の値
    
    stRow = 2
    stCo = 2
    MySheetname = ActiveSheet.Name
    
    Cells(stRow, stCo).Select
    Range(Selection, Selection.End(xlDown)).Select

    'フィルタする。重複値は省く
    Selection.AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    'コピーする
    Selection.Copy
    '新規シート作成
    Sheets.Add After:=Sheets(Sheets.Count)
    '貼り付け
    ActiveSheet.Paste
        
    'tmpシート名取得
    TempSheetname = ActiveSheet.Name
        
    Range("A1").Select
    
    '元のシート選択
    Sheets(MySheetname).Select
    'フィルタ解除
    Cells(stRow, stCo).Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.AutoFilter Field:=1
    
    '--ループ処理
    Dim i
    i = 2
    Do While Sheets(TempSheetname).Cells(i, 1) <> ""
    
    
        'フィルタ名取得
        FilName = Sheets(TempSheetname).Cells(i, 1)
        'フィルタ範囲選択
        Range(Cells(2, 2).End(xlToRight), Cells(i, 2).End(xlDown)).Select
        'フィルタする
        Selection.AutoFilter Field:=1, Criteria1:=FilName
        
        'コピーする
        Cells.Select
        Selection.Copy
        '新規ブック作成
        Workbooks.Add
        '貼り付け
        ActiveSheet.Paste
        '先頭を選択
        Range("A1").Select
        Application.CutCopyMode = False
        '名前を付けて保存する
        ActiveWorkbook.SaveAs Filename:=CurDir & "\" & FilName & ".xlsx"
        ActiveWindow.Close
        Range("A1").Select
        
        'フィルタ解除
        Cells(stRow, stCo).Select
        Range(Selection, Selection.End(xlDown)).Select
        Selection.AutoFilter
    
        i = i + 1
    Loop
    
    
    'tempシート削除
    Sheets(TempSheetname).Delete
    
    Range("A1").Select
    
    '確認メッセージ表示
    Application.DisplayAlerts = True
    '描画戻す
    Application.ScreenUpdating = True
    
    Exit Sub
Error:
    MsgBox "予期せぬエラーが発生しました"
    
End Sub

##履歴
2022/3/12 作成