VBA

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

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

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

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

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

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

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

前提条件

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

コード_テーブル使用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

まとめ

いかがでしょうか。
冒頭でもいいましたが、横展開ができる基本として知っておくと武器になると思います。

また、テーブルを使用したものと使用してないものを書かせてもらいましたが、
テーブルを使用しないとベタ打ちが多くなりました。
ベタ打ちしないで書くことも可能なんですが、コードが長くなるし、メンテナンスもやりにくくなります。

やはりテーブルは活用してほしいです。
覚えると便利です。
いつか記事書きます。

ではでは。