シーゴの Excel 研究室

タイトル変更しました （旧称：今日を乗り切るExcel研究所）

トップ > VBA > 【VBA】表から特定のデータのみを別シートに抽出したい【100本ノック】

【VBA】表から特定のデータのみを別シートに抽出したい【100本ノック】

VBA

エクセルの神髄様の Twitter 企画「VBA100本ノック」に便乗した解答記事です。 今回はその9本目をやります。AdvancedFilter を使ってみます。

お題：VBA100本ノック 9本目：フィルターコピー

問題ページ

方針

セル操作でデータを抽出するロジックを手組みしてもいいのですが、Excel 自体がもともとフィルター機能をいくつも持っています。 ここは折角なので Excel にやってもらいましょう。

そのうち、VBA から呼び出せる機能がいくつか考えられます。

  • AutoFilter メソッドを使う
  • AdvancedFilter メソッドを使う
  • FILTER 関数を使う（Microsoft 365 版の Excel のみ）

これまでの回答をざっと見たところ、AdvancedFilter メソッドを使った解答が見当たらなかったなかったので、これを使ってみることにします。

解答：AdvancedFilter を使ってみる

Option Explicit

Sub VBA100_009()
    Dim gradebook As Workbook
    Set gradebook = ActiveWorkbook
        
    Dim table As Range
    Set table = gradebook.Worksheets("成績表").Range("A1").CurrentRegion
    If table.Rows.Count < 2 Then Beep: Exit Sub
    
    Dim resultSheet As Worksheet
    Set resultSheet = getWorksheet(gradebook, "合格者")
    If resultSheet Is Nothing Then Exit Sub
        
    ' 抽出条件
    Dim criteria As Range
    Set criteria = resultSheet.Range("B1:B2")
    criteria.Cells(1).Value = "合否判定"
    criteria.Cells(2).Value = "合格"
    
    ' 抽出結果
    Dim extract As Range
    Set extract = resultSheet.Range("A1")
    extract.Cells(1).Value = "氏名"
    
    table.AdvancedFilter xlFilterCopy, criteria, extract
    
    criteria.Clear
    resultSheet.Names("Criteria").Delete
    resultSheet.Names("Extract").Delete
End Sub

Function getWorksheet(wbk As Workbook, sheetName As String) As Worksheet
    Dim sht As Object
    On Error Resume Next
    Set sht = wbk.Sheets(sheetName) ' Worksheet 以外のシートも考慮
    On Error GoTo 0
    If Not sht Is Nothing Then
        sht.Activate
        If sht.Delete = False Then Exit Function
    End If
    Set getWorksheet = wbk.Worksheets.Add
    getWorksheet.Name = sheetName
End Function

　

　

考察

Advanced Filterというのは「フィルターオプション」の英語版表示名です。

フィルターオプションは表形式のセル範囲から高度な条件でデータの絞り込み・抽出を可能にするものです。

有用なのに日本語の名前で損をしている機能ですね。 これを開くボタンが「詳細設定」というのもまた意味が分かりません。

f:id:shego:20210123151221p:plain

フィルターオプションのインターフェースが AdvancedFilter メソッドです。

AdvancedFilter メソッドはフィルターオプションの各入力項目に対応するパラメータに持ちます。

  • Action 「抽出先」
  • CriteriaRange 「検索条件範囲」
  • CopyToRange 「抽出範囲」
  • Unique 「重複するレコードは無視する」

また日本語名は意味が分かりません。

まず、フィルターオプションの「リスト範囲」はデータの Range そのものになります。 リスト範囲には見出し行が必要です（表形式）

Action には、データを単に「絞り込み（Filter）」するのか（xlFilterInPlace）、外部に「抽出（Extract）」するのか（xlFilterCopy）を指定します。

抽出では、結果を元のデータ範囲とは別のセル範囲や別シートにコピーし、出力する列も選択できます。

CriteriaRange には絞り込み条件を定義したセル範囲を指定します。

フィルターオプションでは、絞り込み条件はシート上の表形式で指定します。

f:id:shego:20210207000423p:plain

条件表の見出しは列を、データ部には比較式を文字列で入力します。 単なる数値や比較式でない文字列は、等値比較されます。

条件表に行を追加することよって、オートフィルタにはできない、OR条件でも表現できます。

さらに、条件表の見出しが空セルか、元データの列見出しにない文字列であると、数式で条件式を記述することができます。 この条件式では、セル参照や見出しを指定することができて、それらを使って元データの1行目に対する条件式を記述すると、すべての行で評価されて、結果が真になった行のみが絞り込まれます。

例えば「VBA100本ノック 8本目：点数の合否判定」の課題であった合否判定条件で直接表データを絞り込むには、次ような条件表作成して「検索条件範囲」に指定します。

f:id:shego:20210206223753p:plain

これに対応する VBA コードは以下のようになります。

    Dim table As Range
    Set table = ActiveSheet.Range("A1").CurrentRegion
            
    ' 抽出条件
    Dim criteria As Range
    Set criteria = ActiveSheet.Range("H1:H3")
    criteria.Cells(1).Value = "合否条件"
    criteria.Cells(2).Formula = "=SUM(B2:F2)>=350"
    criteria.Cells(3).Formula = "=COUNTIF(B2:F2,""<50"") =0"
        
    table.AdvancedFilter xlFilterInPlace, criteria

CopyToRange には、Action で抽出（xlFilterCopy）した場合の抽出先（コピー先）のセル範囲を指定します。 抽出先は元データと別シートでも構いません。

抽出先に指定したセル範囲の先頭行には抽出したい列の見出しを入力しておきます。

Unique は True を指定すると抽出結果から重複データを排除します。

また、CriteriaRange を省略して Unique を True にすれば、単に元データからの重複の排除ができます。

ところでフィルターオプションの抽出結果は、元データが変更されても自動更新されません。 元データの変更を結果に反映するには、抽出条件を入力しなおしてから再実行する必要があります。 その手間を軽減するためか、抽出条件や抽出先には「名前」が設定されます。

本記事解答の実装では、その名前（「Criteria」 と 「Extract」）を最後に削除しています。

フィルターオプションにはクセがあり、 UI 的にも使いづらい機能ですが、VBA からの扱いはそんなに難しくないようです。

特に条件表や抽出先で指定する列の突き合わせを、列見出しから自動で判断してくれるので、プログラムで列位置を取り回す必要がなくて非常に楽です。

関連記事

www.shegolab.jp