필터를 걸어 시트마다 전기하는 매크로 그 2

이번에는
"시트와 일치하는 항목을 필터로 추출하고 가시 셀로 복사"
매크로는 매크로 시트의 세 번째 행의 셀을 참조하여 시트를 생성하도록 수정되었습니다.
아래 그림과 같은 느낌입니다.
매크로 사용 전
매크로 사용 후

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

다음 번에
추출하는 열의 항목을 자동으로 검출해 시트의 작성~가시 셀로 copipe 할 수 있도록 개수하고 싶습니다.