フィルターをかけてシートごとに転記するマクロ その3

今回は
『シートと一致する項目をフィルターで抽出し可視セルでコピペする』
マクロを、特定の列の単語をもとにシートを自動生成されるように改修しました。

シートの自動生成ですが、下図の方法で「マクロ」シートのA列のセルを参照してシートの作成ができるよう、コードを追加しました。

Option Explicit

Sub buntatu03()

'   マクロシート、分割前シートを変数で宣言
    Dim makuroWs As Worksheet
    Set makuroWs = Worksheets(1)
    Dim bunkatumaeWs As Worksheet
    Set bunkatumaeWs = Worksheets(2)
    
'   分割前シートのE列をマクロシートのA列にコピペする
    With bunkatumaeWs
        .Activate
        Range("E:E").Copy makuroWs.Range("A1")
    End With
    
'   マクロシートのA列の重複を削除し、昇順に並び替える
    With makuroWs
        .Activate
        Range("A:A").RemoveDuplicates Columns:=Array(1), Header:=xlYes
        Range("A1").Sort Key1:=Range("A2"), Order1:=xlAscending, Header:=xlYes
    End With
        
'   マクロシートのA列の最下行を確認
    Dim makuroLastLine As Long
    makuroLastLine = makuroWs.Cells(Rows.Count, 1).End(xlUp).Row
    Debug.Print makuroLastLine
    
'   A列の2行目以降のセルに記載された名前のシートを作る
    Dim j As Long
    For j = 2 To makuroLastLine
    
        Worksheets.Add After:=Sheets(j)
        
        Dim newWs As Worksheet
        Set newWs = Worksheets(1 + j)
        
        Dim group As String
        group = makuroWs.Cells(j, 1)
        newWs.Name = group
        
    Next j

'   新しく作ったシートに「課」ごとに内容を転記する（フィルターで抽出→可視セルでコピペ）
    Dim i As Long
    For i = 3 To Worksheets.Count

        Dim wsName As String
        wsName = Worksheets(i).Name
        Debug.Print wsName

        With bunkatumaeWs.Range("A1")
            .AutoFilter Field:=5, Criteria1:=wsName
            .CurrentRegion.SpecialCells(xlVisible).Copy Worksheets(i).Range("A1")
            .AutoFilter
        End With

    Next i
    
'   マクロシートのA列を削除しセルA1を選択して保存する
    With makuroWs
        .Activate
        Range("A:A").Delete
        Range("A1").Activate
    End With
    ThisWorkbook.Save

End Sub

マクロに操作を任せている部分が多いので、人的ミスも少なくなりそうです！
このマクロは一旦ここで完了とします。

次回はピボットを使ったマクロを作成する予定です。