【VBA】オートフィルタを使用して表からデータを抽出する

0

    <機能>
    (1)アクティブシートにテスト用の表を作成します
     ※出典 外務省「海外在留邦人数調査統計 (平成27年要約版)
    (2)AutoFilterメソッドを使用して表からデータを抽出します

     ・在留邦人数が10000人以上の国
     ・国名が英国、ボリビア、ネパール
     ・国名に「国」が含まれている
     ・国名に「国」が含まれていて、かつ在留邦人数が50000人以上(複数列条件)
     ・在留邦人数が30000人以上、100000人以下(単一列複数条件)
     ・在留邦人数が下位15件(36-50位)

    <動作検証&開発環境>
    Microsoft Office 2016

    <使い方>
    適当なところにソースを張り付けてください
    オートフィルタを設定する()を呼び出すと2秒毎に上記抽出を実施します

    <実行イメージ>
    テスト用の表を自動作成
    VBA,オートフィルタ,AutoFilter,Criteria,Operator,表を作成
    AutoFilterメソッドで抽出
    VBA,オートフィルタ,AutoFilter,Criteria,Operator,AutoFilterメソッドで抽出

     

    '********************************************

    'VBAでオートフィルタを設定する

    '(1)アクティブシートにテスト用の表を作成

    '(2)オートフィルタを設定

    '(3)在留邦人数が10000人以上の国を抽出

    '(4)国名が英国、ボリビア、ネパールのレコードを抽出

    '(5)国名に「国」が含まれているレコードを抽出(部分一致)

    '(6)国名に「国」が含まれていて、かつ在留邦人数が50000人以上のレコードを抽出(複数列条件)

    '(7)在留邦人数が30000人以上、100000人以下のレコードを抽出(単一列複数条件)

    '(8)在留邦人数が下位15件(36-50位)のレコードを抽出

    'メソッドの引数「Operator」への設定値(XlAutoFilterOperator)は下記参照

    https://msdn.microsoft.com/ja-jp/library/office/ff839625.aspx

    '********************************************

    Sub オートフィルタを設定する()

        Dim gyo As Long

        

        '//(1)テストデータ「平成26年海外在留邦人数」表を作成

        SetTestData

        

        '//2列目(B列)でデータの入っている最終行を取得

        gyo = Cells(Rows.Count, 2).End(xlUp).Row

        If gyo < 4 Then

            MsgBox "表「国(地域)別在留邦人数上位50位」が見つかりません", vbCritical

            Exit Sub

        End If

        

        '//(2)オートフィルタを設定する

        '//B列(順 位):field1(指定範囲の左から1列目)

        '//C列(国 名):field2(指定範囲の左から2列目)

        '//D列(邦人数):field3(指定範囲の左から3列目)

        

        '全ての列のオートフィルタを解除

        Range("B3:D" & CStr(gyo)).AutoFilter 1

        Range("B3:D" & CStr(gyo)).AutoFilter 2

        Range("B3:D" & CStr(gyo)).AutoFilter 3

        

        '//(3)在留邦人数が10000人以上の国を抽出

        Cells(2, 2) = "(3)在留邦人数が10000人以上の国を抽出"

        '絞込みを実施

        Range("B3:D" & CStr(gyo)).AutoFilter Field:=3, Criteria1:=">=10000"

        DoEvents

        Application.Wait Now + TimeValue("0:00:02")

        

        '//(4)国(地域)名が英国、ボリビア、ネパールのレコードを抽出

        Cells(2, 2) = "(4)国(地域)名が英国、ボリビア、ネパールのレコードを抽出"

        '先にオートフィルタを解除

        Range("B3:D" & CStr(gyo)).AutoFilter 3

        '絞込みを実施

        Range("B3:D" & CStr(gyo)).AutoFilter Field:=2, _

                            Criteria1:=Array("英国", "ボリビア", "ネパール"), _

                            Operator:=xlFilterValues

        DoEvents

        Application.Wait Now + TimeValue("0:00:02")

        

        '//(5)国(地域)名に「国」が含まれているレコードを抽出(部分一致)

        Cells(2, 2) = "(5)国(地域)名に「国」が含まれているレコードを抽出(部分一致)"

        '先にオートフィルタを解除

        Range("B3:D" & CStr(gyo)).AutoFilter 2

        '絞込みを実施

        Range("B3:D" & CStr(gyo)).AutoFilter Field:=2, Criteria1:="*国*"

        DoEvents

        Application.Wait Now + TimeValue("0:00:02")

        

        '//(6)国名に「国」が含まれていて、かつ邦人数が50000人以上のレコードを抽出(複数列条件)

        Cells(2, 2) = "(6)国名に「国」が含まれていて、かつ邦人数が50000人以上のレコードを抽出(複数列条件)"

        '先にオートフィルタを解除

        Range("B3:D" & CStr(gyo)).AutoFilter 2

        '絞込みを実施

        Range("B3:D" & CStr(gyo)).AutoFilter Field:=2, Criteria1:="*国*"

        Range("B3:D" & CStr(gyo)).AutoFilter Field:=3, Criteria1:=">=50000"

        DoEvents

        Application.Wait Now + TimeValue("0:00:02")

        

        '//(7)在留邦人数が30000人以上、100000人以下のレコードを抽出(単一列複数条件)

        Cells(2, 2) = "(7)在留邦人数が30000人以上、100000人以下のレコードを抽出(単一列複数条件)"

        '先にオートフィルタを解除

        Range("B3:D" & CStr(gyo)).AutoFilter 2

        Range("B3:D" & CStr(gyo)).AutoFilter 3

        '絞込みを実施

        Range("B3:D" & CStr(gyo)).AutoFilter Field:=3, Criteria1:=">=30000", _

                                      Operator:=xlAnd, Criteria2:="<=100000"

        DoEvents

        Application.Wait Now + TimeValue("0:00:02")

        

        '//(8)在留邦人数が下位15件(36-50位)のレコードを抽出

        Cells(2, 2) = "(8)在留邦人数が下位15件(36-50位)のレコードを抽出"

        '先にオートフィルタを解除

        Range("B3:D" & CStr(gyo)).AutoFilter 3

        '絞込みを実施

        Range("B3:D" & CStr(gyo)).AutoFilter Field:=3, Criteria1:="15", _

                                      Operator:=xlBottom10Items

        DoEvents

        Application.Wait Now + TimeValue("0:00:02")

        

        MsgBox "おわりました", vbInformation

    End Sub

     

    '********************************************

    'シートに「平成26年海外在留邦人数」表を作成する

    '出典 外務省「海外在留邦人数調査統計 (平成27年要約版)

    '********************************************

    Sub SetTestData()

        Dim ar As Variant

        ar = Array("順位,国(地域)名 ,在留邦人数", "1,米国,414247", _

        "2,中国,133902", "3,オーストラリア,85083", "4,英国,67258", "5,タイ,64285", _

        "6,カナダ,63252", "7,ブラジル,54377", "8,ドイツ,39902", "9,フランス,38349", _

        "10,韓国,36708", "11,シンガポール,35982", "12,マレーシア,22056", _

        "13,フィリピン,18870", "14,台湾,18592", "15,インドネシア,17893", _

        "16,ニュージーランド,16705", "17,イタリア,13687", "18,ベトナム,13547", _

        "19,アルゼンチン,11675", "20,スイス,10166", "21,メキシコ,9186", _

        "22,インド,8313", "23,スペイン,8080", "24,オランダ,6959", _

        "25,ベルギー,5402", "26,グアム(ハガッニャ総),4484", "27,ペルー,3585", _

        "28,パラグアイ,3554", "29,アラブ首長国連邦,3543", "30,スウェーデン,3302", _

        "31,オーストリア,3027", "32,ボリビア,2897", "33,ロシア,2732", _

        "34,カンボジア,2270", "35,トルコ,2049", "36,アイルランド,1767", _

        "37,フィンランド,1759", "38,チェコ,1750", "39,チリ,1580", _

        "40,デンマーク,1509", "41,南アフリカ,1377", "42,コロンビア,1355", _

        "43,ミャンマー,1330", "44,ハンガリー,1287", "45,ポーランド,1255", _

        "46,ネパール,1095", "47,ノルウェー,1065", "48,エジプト,1019", _

        "49,スリランカ,1013", "50,イスラエル及びガザ地区等,997")

        

        ThisWorkbook.Activate

        Cells.Select

        Selection.Clear

        Selection.ColumnWidth = 15

        Selection.RowHeight = 20

        Selection.Font.Name = "MS ゴシック"

        Selection.Font.Size = 10

        '折り返して全体を表示する

        Selection.WrapText = True

        Range("A1").Select

        

        '//データをシートに展開

        Dim i As Integer

        Dim wkbuf As Variant

        

        '//表のタイトルを出力

        Cells(1, 1) = "国(地域)別在留邦人数上位50位(平成26年10月1日現在)"

        Range("A1:B2").WrapText = False

        

        For i = 0 To UBound(ar)

            wkbuf = Split(ar(i), ",")

            '不正なデータであれば次レコードへ

            If UBound(wkbuf) < 2 Then GoTo nextrec

            'データを表示

            '表はB3セルより出力する

            Cells(i + 3, 2) = wkbuf(0)

            Cells(i + 3, 3) = wkbuf(1)

            Cells(i + 3, 4) = wkbuf(2)

            

    nextrec:

        Next

        

        '罫線を引く

        Range("B3:D" & CStr(UBound(ar) + 3)).Borders.LineStyle = xlLineStyleNone

        Range("B3:D" & CStr(UBound(ar) + 3)).Borders.LineStyle = xlContinuous

        

    End Sub

     

    よろしければポチッと押してください

    プログラマー ブログランキングへ

     



    calendar

    S M T W T F S
    1234567
    891011121314
    15161718192021
    22232425262728
    293031    
    << October 2017 >>

    profile

    others

    mobile

    qrcode