【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年要約版)」
    'http://www.mofa.go.jp/mofaj/toko/page22_000043.html
    '********************************************
    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
        '//A1セルよりデータをシートに展開
        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
     

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

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

     



    selected entries

    categories

    calendar

    S M T W T F S
         12
    3456789
    10111213141516
    17181920212223
    24252627282930
    31      
    << March 2024 >>

    profile

    others

    archives