【Excel VBA】大量データからマッチングデータを抽出

スポンサーリンク

Excelワークシートでマッチングデータを抽出する場合、通常はVLookUp関数を使います。高速化させたい場合Index関数とMatch関数を組み合わせてデータを取り出したります
しかし、大量のデータを処理する場合、各セルにこれらの関数が埋め込まれていると、処理ごとに再計算が発生し画面に砂時計が出てきて動かなくなり、最悪の場合Excelが動かなくなってしまいます
では、そんな場合どうすればよいでしょうか?

そんな時には、VBAで解決するのがオススメです
今回は一意のデータ(ID番号など)に対して、別シート(Excel、CSV)から貼り付けた大量のデータの中から、マッチングしたデータを取り出して貼り付ける処理について説明します
「配列」と「Match関数」を使って素早く取り出していく処理です

「汎用でだれでも使えて活用できるように考えてVBAを使う」というポリシーで書いています

大量データのマッチング(比較・照合)処理はVBAを使うのがオススメです

スポンサーリンク

「配列」と「Match関数」を使ってデータを高速で見つける

・リストデータのシートと貼付元のデータシートの二つを用意します
・ここではリストデータのシートを「貼付先_シート」としています
・大量データの入ったシートはわかりやすく「貼付元_シート」としています

「貼付先_シート」がこちらです。リストデータと見出しだけのシートです

汎用で使えるようにするため、1~2行は設定用に使用します
下の「貼付元_シート」にも同様とします

「貼付元_シート」です。データがいっぱい入っています。

「貼付先_リスト」シートのリストにマッチングするデータをここから探し出します

マッチングデータの抜き出し、貼り付けも「配列」で高速処理

高速化するためのVBA設定

・VBAの高速化に必須の設定を別プロシージャにして汎用で使えるようにしました
・今回使わない項目はコメントアウトしています(状況により変更します)
実行、終了時にCallで呼び出して使用します
・今回のテストコードでは大きな影響はないと思いますが実戦では、セルに計算式が多数設置してあったり、別ブックを操作したりする場合など各種イベントの発生を抑えるために必要です

Sub マクロ開始()
    With Application
        .ScreenUpdating = False            '画面描画を停止
        .EnableEvents = False              'イベントを抑止
        .DisplayAlerts = False             '確認メッセージを抑止
        .Calculation = xlCalculationManual '計算を手動に
        '.Cursor = xlWait
    End With
End Sub

Sub マクロ終了()
    With Application
        '.StatusBar = False                   'ステータスバーを消す
        .Calculation = xlCalculationAutomatic '計算を自動に
        .DisplayAlerts = True                '確認メッセージを開始
        .EnableEvents = True                 'イベントを開始
        .ScreenUpdating = True              '画面描画を開始
        '.Cursor = xlDefault    
    End With
End Sub

・最初に設定をMatch関数で調べて変数にセットしていきます
・「貼付先_シート」IDデータを「貼付元_シート」からMatch関数で存在位置を検索
・見つかった位置(行)の目的データをLoop処理で配列に格納し「貼付先_シート」に書き出します

【設定のルール】は次のとおり
・▼ = Target列(マッチングに使うデータが入っている列を指定)
・1~順番に数字で指定(取り出したいデータの入っている列を指定)
・G1セルにデータの先頭行(この例では4)
・K1セルに「貼付先_リスト」(取り出したデータを貼り付けるシート名)
・VBAマクロの実行は「貼付元_リスト」から実行します

データ処理を実行するVBAコードがこちらです

'貼付け元シート上で開始すること
Sub Array_match()
    Dim workSh As Worksheet, prefSh As Worksheet
    Dim sName As String
    Set prefSh = ThisWorkbook.ActiveSheet
    sName = prefSh.Range("K1").Value '取得データ貼付け先シート名
    Set workSh = ThisWorkbook.Worksheets(sName)
    Dim ptCol As Long, pFlgCol As Long
    Dim pMCol As Long, pCol() As Long
    Dim wtCol As Long, wFlgCol As Long
    Dim wMCol As Long, wCol() As Long
    Dim pRow As Long, wRow As Long
    Dim i As Long
    
    '▼マーク(ターゲット)列を検索
    ptCol = Application.WorksheetFunction.Match("▼", prefSh.Rows(2), 0)
    wtCol = Application.WorksheetFunction.Match("▼", workSh.Rows(2), 0)
    '設定行の最大数
    pMCol = Application.WorksheetFunction.Max(prefSh.Rows(2))
    wMCol = Application.WorksheetFunction.Max(workSh.Rows(2))
    'データ開始列の設定
    pRow = prefSh.Range("G1")
    wRow = workSh.Range("G1")
    '設定の不整合を判定する処理
    If pMCol <> wMCol Then
        MsgBox "引き当てる列の数が不整合のため中止します!"
        Exit Sub
    End If
    ReDim pCol(1 To pMCol)  '指定列の指定を代入する
    pFlgCol = 0 '指定列の配置が連続しているかどうか調べる「0」は連続
    For i = 1 To pMCol
        pCol(i) = Application.WorksheetFunction.Match(i, prefSh.Rows(2), 0)
        If i > 1 Then
            If pCol(i) <> pCol(i - 1) + 1 Then pFlgCol = 1 '不連続は「1」
        End If
    Next
    ReDim wCol(1 To wMCol)  '貼付け先も同様に調べる
    wFlgCol = 0
    For i = 1 To wMCol
        wCol(i) = Application.WorksheetFunction.Match(i, workSh.Rows(2), 0)
        If i > 1 Then
            If wCol(i) <> wCol(i - 1) + 1 Then wFlgCol = 1 '不連続は「1」
        End If
    Next
    Dim workShEndR As Long, prefShEndR As Long
    Dim tgetTmpR As Long, tmpStr As Variant '文字列の場合もあるのでVariantで
    '最終行取得
    workShEndR = workSh.Cells(Rows.Count, wtCol).End(xlUp).Row
    prefShEndR = prefSh.Cells(Rows.Count, ptCol).End(xlUp).Row
    Dim tgetRng As Range
    'ターゲット(ID)の列範囲をセット
    Set tgetRng = Range(prefSh.Cells(pRow, ptCol), prefSh.Cells(prefShEndR, ptCol))
    Dim matchRng As Variant
    Dim MyArray() As Variant

    'スピードアップのため動作を制限する
    Call マクロ開始

    'オートフィルタが設定されていたら解除する
    If (workSh.AutoFilterMode = True) Then workSh.Rows(wRow - 1).AutoFilter
    'ターゲットID件数分のループ
    For tgetTmpR = wRow To workShEndR
       DoEvents		'途中で中断ができるように
       tmpStr = workSh.Cells(tgetTmpR, wtCol).Value '検索対象ID
        '発見できなかった場合エラーとなりマクロが停止するので制御する
        On Error Resume Next
        '対象IDコードを配列から検索
        matchRng = Application.WorksheetFunction.Match(tmpStr, tgetRng, 0)
        If Err <> 0 Then
            matchRng = "" 'ERRORの場合空白に
            Err.Clear
        End If
        If matchRng = "" Then
            '何もしない
        Else
            matchRng = matchRng + wRow - 1 '開始行分をプラス -1
            '配列のメモリ領域割り当て
            ReDim MyArray(1 To pMCol)
            If pFlgCol = 1 Then '不連続の場合はループ、連続の場合は一括書込み
                For i = 1 To pMCol
                    MyArray(i) = prefSh.Cells(matchRng, pCol(i)).Value
                Next
            Else
                MyArray() = prefSh.Range(prefSh.Cells(matchRng, pCol(1)), _
                                    prefSh.Cells(matchRng, pCol(pMCol))).Value
            End If
            If wFlgCol = 1 Then '不連続の場合はループ、連続の場合は一括書込み
                For i = 1 To wMCol
                    workSh.Cells(tgetTmpR, wCol(i)).Value = MyArray(i)
                Next
            Else
                workSh.Range(workSh.Cells(tgetTmpR, wCol(1)), _
                                workSh.Cells(tgetTmpR, wCol(pMCol))) = MyArray
            End If
            Erase MyArray
        End If
    Next

    '動作制限を解除
   Call マクロ終了

    MsgBox "引当て入力が完了しました!"
End Sub

・設定の番号(1~n)の数は、二つのシートで合わせる必要があります
・番号(1~n)は二つのシートで設定する位置を合わせる必要はありません
・順番を変えて抜き出したり、貼り付けたりと自由に変更できます(^^)/

実行速度を比較してみました

・抽出元データの行数は50万行で行う
・ID数は300、1項目(1列)だけの場合、①VlookUp関数で引き当て ②VBAで抜き出し
・ID数は300、3項目(3列)の処理をVBAで、③設定列が同じ場合 ④設定列が違う場合
・ID数は300、5項目(5列)の処理をVBAで、⑤設定列が同じ場合 ⑥設定列が違う場合
・以下、10,000件及び20,000件で同じように計測

・当初の設定では、計算式の入っているセルがほとんどなかったので誤差が出ませんでした
・10000件から、別シートに「集計表」を設定し、貼付け先のデータを集計するように変更して計測

実行速度検証結果でVlookUpが圧勝

設定_(元データ件数50000行)VlookUp関数で引当VBA高速化なしVBA高速化設定後
ID300件、項目数は1項目(1列)6秒17秒17秒
ID300件、項目数は3項目(3列)8秒418秒17秒
ID300件、項目数は5項目(5列)9秒418秒17秒
ID10000件、項目数は1項目(1列)9秒278分18秒7分06秒
ID10000件、項目数は3項目(3列)9秒438分51秒7分17秒
ID10000件、項目数は5項目(5列)9秒528分54秒7分41秒
ID20000件、項目数は1項目(1列)9秒0518分57秒17分02秒
ID20000件、項目数は3項目(3列)9秒8319分29秒17分24秒
ID20000件、項目数は5項目(5列)10秒1920分09秒17分26秒
なんと!! VlookUpの方が圧倒的に速い!!

・VlookUp関数は相当重い再計算処理が入らなければ超高速!(VBAより速い)
Excel2016でVlookUp関数が高速化されたという情報は聞いていましたが本当だった!
・ブックの設定(計算式の入っているセルの数など)によって速度は変化する
・VBAは、高速設定しないと厳しい(遅い)
・VBAは、項目数が増えても速度の変化は少ない(安定している)
・並びの設定が変化してもスピードはあまり変わらない(VBA)
今後はExcel2016以降なら、VBAでVlookUp関数をセルに貼り付けて計算後に値にするなどの処理方法を検討した方が良いのかもしれない(-_-;)

ここまでの「まとめ」と今後の機能追加など

今回の処理の流れは

高速化するためのVBA設定をコードに追加(プロシージャ化)しました
 Application.ScreenUpdating = False ‘画面描画を停止
 Application.EnableEvents = False ‘イベントを抑止
 Application.DisplayAlerts = False ‘確認メッセージを抑止
 Application.Calculation = xlCalculationManual ‘計算を手動に など
・実行速度の検証を行ってみました(ワークシート関数のVlookUpや設定を変えてVBAを実行)
・検証の結果、噂に聞いていたとおり「VlookUp関数」の方が高速であることが確認できた
・「VlookUp関数」以外の関数が大量にセルに貼られている場合、大幅な速度遅延が発生します
VBAは処理速度は安定しておりExcel2016以前なら「VlookUp関数」より高速
【今後の機能追加など…】
・時間のかかるVBA処理の進捗状況がわからないのでストレスが溜まる(-_-;)
・実行中は、Excelで他の作業を行うことができません(これ、かなりストレス!)
・長時間かかるVBA実行中にPCが休止状態やスリープになった場合、VBAも中断してしまいます
 (これも、終わっていると思ったら・・・これも相当なストレスです)
・今回「VlookUp関数」が高速化していることが判明したので、活用法を検討してみたい
・これらをクリアする対策を検討していきます ご期待ください(^^)/

サンプルファイルをダウンロードできます(下記リンク先へ)

記事で使用したサンプルファイルがダウンロードできるページを設置しました
こちら(このリンク先)からご利用ください