Autofilterの応用（AutofilterとDictionaryを使ってリストすべて個別にデータを抽出する方法）

このページでわかること

Autofilterの実務向け応用例です。
データベースからデータを個別に抽出し、転記します。

手順

Dictionaryオブジェクトでダブりのないリストを作成
リストをFor each文で回し、それぞれフィルタリング
シートを新規作成し、フィルタリングした結果を転記

こんにちはhokkyokunです。
前回Autofilterの実践向け応用例です。
結構使えるテクニックだと思うのでよかったら見てください。

僕は実務で、
データを個別でシート毎に貼り付ける作業をすることがあるのですが
ひとつひとつ手でやってると手間なので、マクロを組んでやります。

ここからさらに発展させ、
個別のデータをさらに集計したり、グラフ化したり、
という横展開もできると思いますので、
実務の入り口としてぜひ覚えていただければと思います。

テーブルを使ったコードと使ってないコードを用意しました。
テーブルが苦手って方もいると思うので
どちらかご活用ください。

Contents

前提条件
コード_テーブル使用Ver.（コピペOK）
コード_テーブル不使用Ver.
まとめ

前提条件

毎度おなじみですが、表を作りました。
ここから部毎にデータを抽出し、
部毎にシートを作成して、
表を転記するというのがゴールです。

コード_テーブル使用Ver.（コピペOK）

Sub Autofilterで各部のデータを取り出す()

Dim dicDiv As New Dictionary '部のリスト
Dim table As ListObject '表をテーブルとして扱います。
Dim r As Range 'For each文で使う変数(テーブル用)
Dim l As Variant 'For each文で使う変数(部のリスト用)

Set table = ActiveSheet.ListObjects(1)

'For each文で部のリストを作成
For Each r In table.ListColumns("部").DataBodyRange
    
    'On Error Resume Nextでダブりがあった場合は無視して次の処理を行う
    On Error Resume Next
        dicDiv.Add r.Value, r.Value
    On Error GoTo 0
Next

'部のリストをひとつひとつフィルタリングし、
'抽出されたデータを新しいシートに転記する
With table
    For Each l In dicDiv
        'テーブルの「部」列のインデックス番号＝1番目、検索キーワードは部の名前
        .Range.Autofilter field:=.ListColumns("部").Index, Criteria1:=l
        
        'シートを新規追加します。場所は一番後ろ
        Worksheets.Add after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        
        '名前は部の名前
        ActiveSheet.Name = l
        
        'テーブルの見えているセル＝抽出後の値をコピペ
        .Range.SpecialCells(xlCellTypeVisible).Copy ActiveSheet.Range("A1")
　　Next

    'テーブルのフィルターを最後にキャンセル
    .Range.Autofilter

End With
End Sub

部毎にデータを取り出せました。

コード_テーブル不使用Ver.

Set Rngs = ThisWorkbook.Worksheets("部課リスト").Range("A2:A18")

'For each文で部のリストを作成
For Each r In Rngs
    
    'On Error Resume Nextでダブりがあった場合は無視して次の処理を行う
    On Error Resume Next
        dicDiv.Add r.Value, r.Value
    On Error GoTo 0
Next

'部のリストをひとつひとつフィルタリングし、
'抽出されたデータを新しいシートに転記する
With ThisWorkbook.Worksheets("部課リスト")
    For Each l In dicDiv
        '表の1番目＝「部」の列、検索キーワードは部の名前
        .Range("A1").Autofilter field:=1, Criteria1:=l
        
        'シートを新規追加します。場所は一番後ろ
        Worksheets.Add after:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)
        
        '名前は部の名前
        ActiveSheet.Name = l
        
        '抽出後の値をコピペ
        .Range("A1").CurrentRegion.Copy ActiveSheet.Range("A1")
    Next

    'テーブルのフィルターを最後にキャンセル
    .Range("A1").Autofilter

End With
End Sub