このサイトはCocoonを使っています。現在「ミックスブルー [作者: y.hiroaki氏]」スキンを適用中です(^^)/

【ExcelVBA】配列とMatchでデータ抽出、Findで設定

スポンサーリンク

今回は一意のデータ(ID番号など)に対して別ファイル(Excel、CSV)から該当するデータを検索して探し出し、取り出して貼り付ける処理について書いていきます
「Findメソッド」で設定、「配列」と「Match関数」を使って素早く取り出していく処理です

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

一意のデータ(ID番号など)を別ファイル内を検索して目的データを取り出す処理

記事内容はこんな感じ

・前回まで使用したコードを一部変更して使いまわします
・開いた別ブックからデータを抜き出す処理(別プロシージャでの処理)
・ここまでの「まとめ」と活用法など

スポンサーリンク

前回まで使用したコードを一部変更して使いまわします

今回の設定では、設定する項目の件数が10件を超えてしまうので、「*【*】」で先頭の数字を検索した場合に下一桁が重複してしまう(1と11、2と12など)
それを回避するため、1桁の数値は「01、02.、03・・・)のように文字列とすることに変更

別ブックを開き設定とともに別プロシージャに引き継ぐ

・別ブックからデータを取り出す部分は、別プロシージャに必要な変数を「参照渡し」で引き継ぐ
・別ブックを開いた後、Call index_match2(tgWb, arr) と呼び出す
・プロシージャ名が「index_match」となってますがindexは不使用「配列」と「Match」を使用

'開いた別ブックから目的のデータを抜き出す処理
Sub TargeDataPullOut()
    Dim FCell As Range
    Dim tRow As Long, h As Long, i As Long
    Dim res As Long, n As Long
    Dim tgFCount As Long
    Dim tgCellCount As Long
    Dim tgFName As String, tgFPN As String
    Dim Msg As String
    Dim tgAd As String
    Dim db As Variant
    Dim myWb As Workbook, tgWb As Workbook
    Dim mainSh As Worksheet, tgSh As Worksheet
    Dim gatSh As Worksheet
    Dim colF As Long, rowF As Long, colT As Long
    Dim arr() As Variant
    
    '設定数を取得
    n = Application.CountIf(Cells, "*【*】")
    '設定取得へ
    arr() = Setting(n)
    '2【フォルダ内ファイル名】行列取得
    colF = Range(arr(2)).Column     '列番番号
    rowF = Range(arr(2)).Row        '行番号
    '3【Targetの設定用符号】'Target番地の列位置
    colT = Range(arr(3)).Column + 1 '3列右の列番号
    '一応フォルダの存在チェック
    If Dir(arr(1), vbDirectory) = "" Then   '1【フォルダPATH】
        res = MsgBox("フォルダ設定に誤りがあります。" & _
                        "確認後に再実行してください。", vbYes, _
                        "データ集計"): Exit Sub
    End If
    'フォルダ名の末尾に\がある場合削除(ルートかどうか判別)
    If Right(arr(1), 1) = "\" Then arr(1) = Left(arr(1), (Len(arr(1)) - 1))
    Set myWb = ThisWorkbook
    Set mainSh = myWb.ActiveSheet 'マクロをスタートしたシート
    Set gatSh = myWb.Worksheets(arr(5)) '5【データ集計用シート名】
    Application.ScreenUpdating = False
    With mainSh
        i = 1 'ループカウンターセット
        If rowF >= 2 Then rowF = rowF - i
        '対象ファイル数をカウント
        tgFCount = WorksheetFunction.CountA(.Columns(colF)) - rowF
        '貼付け先シートのデータ入力行を調べる
        tRow = gatSh.Cells(Rows.Count, 1).End(xlUp).Row
        'Targetセル数をカウント
        tgCellCount = WorksheetFunction.CountA(.Columns(colT))
        Do Until i > tgFCount 'ループ開始
            tgFName = .Cells(rowF + i, colF) '読み込むファイル名をセット
            tgFPN = arr(1) & "\" & tgFName    'フルパスのファイル名
            If Dir(tgFPN) = "" Then
                res = MsgBox(tgFPN & " は存在しません。" & _
                        "このファイルを飛ばして続行しますか。", _
                        vbYesNo, "データ集計")
                If res = vbYes Then
                    GoTo nextloop
                Else
                    Application.ScreenUpdating = True
                    Exit Sub
                End If
            End If
            On Error Resume Next  '実行時エラー対策
            'ファイルをリードオンリーで開く
            Set tgWb = Workbooks.Open(fileName:=tgFPN, ReadOnly:=True)
            'データ抜き出し処理へ
            Call index_match2(tgWb, arr)
            'ファイルを閉じる
            Workbooks(tgFName).Close savechanges:=False
nextloop:
            i = i + 1
        Loop
        gatSh.Activate
        ActiveWindow.Visible = True
        Range("a1").Select
    End With
    Application.ScreenUpdating = True
    MsgBox "データの取得が完了しました", vbOKOnly, "データ取得"
End Sub

シートの設定情報を取得する関数(変更後)

'シートに書き出した設定の情報を取得する
Function Setting(n As Long) As Variant
    Dim FCell As Range
    Dim myWb As Workbook
    Dim mainSh As Worksheet
    Dim arr() As Variant
    Dim i As Long
    
    ReDim arr(1 To n) As Variant
    Application.ScreenUpdating = False
    Set myWb = ThisWorkbook
    Set mainSh = myWb.ActiveSheet
    With mainSh
        '設定取得
        For i = 1 To n
            Set FCell = .Cells.Find(What:=Format(i, "00") & "【*】")
            If i = 2 Or i = 3 Then
                arr(i) = FCell.Offset(0, 1).Address
            Else
                arr(i) = FCell.Offset(0, 1)
            End If
        Next
    End With
    Setting = arr()
    Application.ScreenUpdating = True
End Function

【補足説明】
設定を取得する部分 Set FCell = .Cells.Find(What:=Format(i, “00”) & “【*】”)  
Format関数で数値を二けたの文字列に変換して処理するように変更しました

集約するシート「集計」の例

ID番号(一意)を検査して空白部分のデータを別ブックから取り込んでいく処理

開いた別ブックからデータを抜き出す処理

・参照渡しされた「別ブック」と「設定情報」を使用
・「ID」の検索や抜き出す「データ範囲」などは「配列」に代入
メモリ上の「配列」内で処理を行うので高速

開いた別ブックからデータを抜き出すプロシージャ

'データ取得処理(配列)
Sub index_match2(wb As Workbook, ar As Variant)
    'ar(5) = 05【データ集計用シート名】
    'ar(6) = 06【Targetシート名】
    'ar(7) = 07【ID設定列】         'ar(12) = 12【TargetID設定列】
    'ar(8) = 08【名称列】           'ar(13) = 13【Target名称列】
    'ar(9) = 09【DATE開始行】       'ar(14) = 14【TargetDATE開始行】
    'ar(10) = 10【取得範囲開始列】  'ar(15) = 15【Target範囲開始列】
    'ar(11) = 11【取得範囲最終列】  'ar(16) = 16【Target範囲最終列】
    Dim workSh, tgetSh, mySh As Worksheet
    Set mySh = ThisWorkbook.ActiveSheet
    Set workSh = ThisWorkbook.Worksheets(ar(5)) '05【データ集計用シート名】
    Set tgetSh = wb.Worksheets(ar(6)) '06【Targetシート名】
    Dim wShEndR As Long, tShEndR As Long    '最終行保存用
    Dim tmpStr As String                    '検索対象ID保存用
    wShEndR = workSh.Cells(Rows.Count, ar(7)).End(xlUp).Row
    tShEndR = tgetSh.Cells(Rows.Count, ar(12)).End(xlUp).Row
    'Matchで検索する範囲とFindで返答する範囲指定用変数
    Dim tgetRng As Range    'ターゲットID用
    Dim aggRng As Range     '集約シートID用
    Dim matchRng As Long    '検索ID位置
    Dim vSpRng As Variant   '指定範囲のデータ配列
    Dim MyArray As Variant  '取得配列保存用
    Dim tgetTmpR As Long, l As Long 'ループカウンター用
    
    'オートフィルターがセットされていたら解除
    If workSh.AutoFilterMode = True Then workSh.Range("A1").AutoFilter
    If tgetSh.AutoFilterMode = True Then tgetSh.Range("A1").AutoFilter
    
    'TargetシートのIDをセット
    Set tgetRng = tgetSh.Range(tgetSh.Cells(ar(14), ar(12)), tgetSh.Cells(tShEndR, ar(12)))
    '貼り付け先シートのIDをセット
    Set aggRng = workSh.Range(workSh.Cells(ar(9), ar(7)), workSh.Cells(wShEndR, ar(7)))
    'Targetの対象範囲を配列に入れる
    vSpRng = tgetSh.Range(tgetSh.Cells(ar(14), ar(15)), tgetSh.Cells(tShEndR, ar(16)))

    '発見できなかった場合エラーとなりマクロが停止するので、On Errorステートメントで制御する
    On Error Resume Next
    Application.CutCopyMode = False
    '実際の処理
    '貼り付け先の配列をいったん初期化してセット
    ReDim MyArray(UBound(vSpRng, 1), UBound(vSpRng, 2)) As Variant
    For tgetTmpR = LBound(vSpRng, 1) To UBound(vSpRng, 1) 'データ行分をループ
        tmpStr = tgetRng(tgetTmpR).Value  '検索対象ID
        '対象IDの位置を検索
        matchRng = Application.WorksheetFunction.Match(tmpStr, aggRng, 0)
        If matchRng <> "" Then
            For l = 1 To ar(16) - ar(15) + 1 '[最終列]-[範囲開始列]+1
                'MyArrayは(0~、0~)なので「1」マイナス
                MyArray(0, l - 1) = vSpRng(tgetTmpR, l) '指定行のセルデータを配列に代入
            Next
            With workSh
                matchRng = matchRng + ar(9) - 1
                .Range(.Cells(matchRng, ar(10)), .Cells(matchRng, ar(11))) = MyArray '配列を貼付
                .Range(.Cells(matchRng, ar(11) + 1), .Cells(matchRng, ar(11) + 1)) = Now '最終列の次に日時
            End With
        End If
    Next
    Erase MyArray   '配列初期化
    Erase vSpRng
    Application.CutCopyMode = True
End Sub

【補足説明】
・ループは「対象ファイル数」と開いたブック内の「データ行数(件数)」の2回
・取り出したデータを配列に格納し、貼り付け先範囲に一括で書き出し
・書き出し後に、最終列の後ろに日時を書き出し(処理したのが何時なのかわかる)

ここまでの「まとめ」と活用法など

今回の処理の流れは

・別ファイルを保存しているフォルダを指定 ⇒ フォルダ内のファイル名を取得
・処理に必要な設定情報の取得 ⇒ ファイル(別ブック)を開く
・別ブック内データのIDと集計シートのIDとを比較・検索して
・同一IDのデータを「配列」を使って抽出・貼り付け処理を高速で行う
【活用法など…】
・今回はIDだけを使用しましたが、B列の「名称」やC列の「DATE」など複数列を使った方法
・データをソート(例えば「名称」)して一括で限定範囲だけ処理すればもっと高速に
・等々、いろいろと検討してみても良いかもね(^^)

次回は、大量データから目的のデータを抜き出してくる処理について書く予定です。今回の応用ですが、100万行を超える大きなデータでも高速処理可能か?是非ご期待ください!

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

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