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

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

Sub buntatu01()
    
'   フィルターをかけるシートを指定
    Dim bunkatumaeWs As Worksheet
    Set bunkatumaeWs = Worksheets(2)
   
'   繰り返し開始（3つ目～最後のシートまで）
    Dim i As Long
    For i = 3 To Worksheets.Count
    
'   転記先のシートを指定
        Dim wsName As String
        wsName = Worksheets(i).Name
        
'   フィルターをかけてE列を指定したシート名と一致したもののみ抽出して可視セルでコピぺ
        With bunkatumaeWs.Range("A1")
            .AutoFilter Field:=5, Criteria1:=wsName
            .CurrentRegion.SpecialCells(xlVisible).Copy Worksheets(i).Range("A1")
            .AutoFilter
        End With
    
    Next i
    
'   ブックを閉じないで保存する
    ThisWorkbook.Save

End Sub

今まで作成したマクロとは異なり、別のブックを操作しないので、意外とシンプルになりました。
次回はシートを自動生成してコピペできるよう改修したいと思います。