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

今回は
『シートと一致する項目をフィルターで抽出し可視セルでコピペする』
マクロを、マクロシートの3行目のセルを参照して、シートを生成するように改修しました。
下図のような感じです。
マクロ使用前
マクロ使用後

Sub buntatu02()

'   1つ目・2つ目のシートを指定
    Dim makuroWs As Worksheet
    Set makuroWs = Worksheets(1)
    Dim bunkatumaeWs As Worksheet
    Set bunkatumaeWs = Worksheets(2)

'   3行目の一番右のセルを指定
    Dim maxSheetCount As Long
    maxSheetCount = makuroWs.Cells(3, Columns.Count).End(xlToLeft).Column

'   セルを参照して3つ目以降のシートを作る
    Dim j As Long
    For j = 1 To maxSheetCount - 1

        Worksheets.Add After:=Sheets(1 + j)
        Dim newWs As Worksheet
        Set newWs = Worksheets(2 + j)
        Dim group As String
        group = makuroWs.Cells(3, 1 + j)
        newWs.Name = group

    Next j

'   シート名を参照してフィルターで抽出し可視セルでコピペ
    Dim i As Long
    For i = 3 To Worksheets.Count

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

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

    Next i

'   1つ目のシートのセルA1をアクティブにしてブックを閉じないで保存する
    makuroWs.Activate
    Range("A1").Activate
    ThisWorkbook.Save

End Sub

マクロでシートを手作業で作る必要がなくなると、だいぶ汎用性が高くなる気がします！
下記のコードでセルを参照して新しいシートを作れるので、他の場面でも結構生かせそうです。

' シートを追加していく（jは整数）
Worksheets.Add After:=Sheets(1 + j)
' 作ったシートに名前を付ける 
group = makuroWs.Cells(3, 1 + j)
newWs.Name = group

次回は
抽出する列の項目を自動で検出してシートの作成～可視セルでコピペできるよう改修したいと思います。