2011年5月21日土曜日

[ExcelVBA] AdvancedFilterでGroupBy

こんにちは。部隊長です。
おなじみExcelVBAのAdvancedFilterを使って、ExcelのデータをDBのようにGROUP BYしてしまおうというネタです。

メニューから行くとフィルタオプションというのがありますが


これを使います。
一番最初にやるのは、GROUPしたい項目を抜き出すことです。
抽出元のシートから、ヘッダーにする項目をコピーし、抽出先のシートに貼っておきます。
同時に、データの抽出先としても貼りつけておきましょう。
この時に、抽出条件の下に条件を書けば任意のデータを抽出する事ができます。
ここでは鈴木さんの年齢をGROUPしてみます(どんだけ鈴木さんいんだよって話ですが)


抽出条件に="鈴木"と書いているのは、単に「鈴木」と書いた場合部分一致になってしまうからです。
また、部分一致の挙動が2002と2003以降等Excelのバージョンで異なるため、
誤動作を防ぐためには="○○"と書くとよいです。
先頭に=を書くと数式扱いになってしまいますので、セルの書式を文字列にするか、
先頭に「'」を打って文字列にしましょう。


それでは先程のフィルタオプションメニューを開き、
まずは抽出先に「選択した範囲」として、データ元にしたいセル範囲を指定しましょう。


次に先ほど用意した抽出先と出力先をそれぞれ
「検索条件範囲」と「抽出範囲」に指定します。

※抽出条件は、指定するしないに関わらずタイトル行入れて最低2行指定!



設定画面に戻ったら、「重複するレコードは無視する」にチェックを入れます。
じつはコレでGroupできるのです。



準備が終わったらOKを押してみましょう。
うまく抽出されましたか?



で、タイトルにVBAって書いたのに長々と操作の説明になってしまいましたが、
コードはこんな感じです。
データシートのフィルタモード解除、出力先のクリアを追加しています。
GROUPしたい場合、unqにTRUEを指定して下さい。


''' TEST
Private Sub test()

    Dim sh As Worksheet
    Dim db As Range, crt As Range, ext As Range
    
  '' 結果のシート
    Set sh = ThisWorkbook.Worksheets("抽出結果シート")
  '' データ範囲指定
    Set db = ThisWorkbook.Worksheets("データ").Range("A:X")
  '' 抽出条件(タイトル含め条件の行数全部)
    Set crt = sh.Range("A2:B3")
  '' 抽出先(タイトル行のみ指定)
    Set ext = sh.Range("D2:E3")
    
    If doAdvancedFilter(db, crt, ext, True) Then
       '’成功
    End If
    
End Sub

''' AdvancedFilter実行
''' データレンジのシートがフィルタされてたら解除する
''' 抽出レンジのデータは末尾までクリアする
''' 検索レンジが1行の場合エラー
''' 検索レンジは2行以上指定すること
Public Function doAdvancedFilter(ByVal dbRange As Range, _
                            ByVal crtRange As Range, _
                            ByVal extRange As Range, _
                            ByVal unq As Boolean) As Boolean

On Error GoTo Err:
    
    Dim sht As Worksheet
    
    If crtRange.Rows.Count <= 1 Then
        MsgBox "抽出条件が不正です"
        Exit Function
    End If
    
    Set sht = dbRange.Parent
    If sht.FilterMode Then sht.ShowAllData
   
    '' 最大行数
    Dim mxR As Long
    Set sht = crtRange.Parent
    mxR = sht.Rows.Count
    
    '' extRangeクリア
    Dim fCell As Range
    Set fCell = extRange.Range("A1")
    fCell.Offset(1, 0).Resize(fCell.Offset(1, 0).End(xlDown).Row - fCell.Row, extRange.Columns.Count).Clear
   
    '' Filter実行
    dbRange.AdvancedFilter xlFilterCopy, crtRange, extRange, unq
    
    doAdvancedFilter = True
    Exit Function
    
Err:
    MsgBox Err.Description

End Function

抽出条件を色々工夫して大変なデータ処理を楽に済ませちゃいましょう!


0 コメント:

コメントを投稿