[[20160727182237]]　『VBA　配列内の比較　高速化』（BK）　ページの最後に飛ぶ

『VBA　配列内の比較　高速化』（BK）

いつも参照させて頂いておりますが、
この度、アイデアをお借りしたく投稿させて頂きます。

単純に以下のData1とData2の2つの文字列を比較し、部分一致すれば、
Data1の横ｾﾙに出力する内容です。
今回は出力箇所ではなく、判定する箇所の高速化のご質問です。

Data1:判定には使用しない文字列(14文字)、30万件の文字列(10文字～100文字)
Data2:5000件の部分文字列(1文字～10文字程度)、判定後にData1に紐付かせる文字列(6ｹﾀ)
※それぞれ多数行x2列のイメージ

Data1の2列目文字列とData2の1列目文字列を配列内で比較し、新しい配列(Data1と同じ大きさ)にData2の紐付かせるデータ(2列目)を同じ添字に代入させます。（出力は別）

Data1/2とも2次元配列に取り込み、以下のｺｰﾄﾞで判定させていますが、
処理速度的に5秒100件程度ですので、とても使える状態ではありません。

    For I = 1 To MaxRow
        For J = 1 To FindMaxRow
            If Data1(I, 2) = Data2(J, 1) Then
                OutData(I, 1) = Data2(J, 2)
            End If
        DoEvents
        Next
        Application.StatusBar = String(Int(I / MaxRow * 10), "■") & _
                           String(10 - Int(I / MaxRow * 10), "□") & _
                           I & "検索を処理中…"

    DoEvents
    Next

言葉で記載すると難しいですが、多量データの文字列判別のアイデアが
あとはFor Eachに変える程度しかありません。

言葉足らずで申し訳ありませんが、アドバイスお願いいたします。

＜使用 Excel：Excel2010、使用 OS：Windows7 ＞

 いかに配列内処理をしているといっても、提示のロジックでは
 30万 x 5000 = 15億回　の比較と、マッチした場合の転記を行っているわけですから
 それは、時間がかかるでしょう。

 ・提示の流れで行くとしても、せめて、内側のループでマッチして転記したら Exit For は最低必要でしょうね。
 ・これだけのデータボリュームであれば、元データを昇順にして、二分検索のMATCH等による処理が効率的かもしれません。
 ・あるいは、データの並びを昇順にできないなら、Data2のほうをDictionaryに格納して、OutDataにはDictionaryからセットするという方式が望ましいと思います。
 　（私の場合はロジックを考えるのが面倒なので、たとえ元データが昇順であってもDictionary方式でやります）

 いずれにしても、処理時間の短縮を目下のテーマとしておられるわけですから、その足をひっぱるステータスバーへの書き込み（おまけに DoEvents も30万回）は
 とりさって、すべて解決した後に、必要なら加えられてはいかがですか。

（β） 2016/07/27(水) 19:41

 追加で

 >>Data1:判定には使用しない文字列(14文字)、30万件の文字列(10文字～100文字) 
 >>Data2:5000件の部分文字列(1文字～10文字程度)、判定後にData1に紐付かせる文字列(6ｹﾀ)

 いまいち、よくわからないのですが、
 具体的なサンプルをアップして説明されれば、回答者側で、処理案回答を行うとした場合に
 より具体的な回答がつくと思います。

（β） 2016/07/27(水) 19:45

 実際のData1,Data2,OutData の中のデータがどうなっているか不明ですが、
 こちらで 30万行２列のData1、5千行２列のData2 を作成。
 Data1の２列目とData2の１列目がマッチするケースが１２万件。

 これで、以下の処理をしますと、１秒もかからずにOutDataへの格納が終了します。
 （なので、ステータスバーの表示は無意味になりますね）

    Set dic = CreateObject("Scripting.Dictionary")

    For i = 1 To UBound(Data2, 1)
        dic(Data2(i, 1)) = Data2(i, 2)
    Next

    For i = 1 To UBound(Data1, 1)
        If dic.exists(Data1(i, 2)) Then OutData(i, 1) = dic(Data1(i, 2))
    Next

（β） 2016/07/27(水) 21:09

Data1は元の長い文字列であり、Data2は検索用の短い文字列ですよね？イコールで判定していますが、部分一致ならInstrかLikeではないでしょうか？もし部分一致判定だとすると、Dictionary案は×になってしまいますよ。

データ数が非常に多いのですが、これExcelの配列をインタプリンタで処理するより、何らかのデータベースに乗せた方が良くないですかね？そしてVBAでは、1件ずつ部分一致のwhereで、Joinした結果を得て表示するだけ。
（???） 2016/07/28(木) 09:31

βさん、???さんご回答ありがとうございます。

βさんにご教示頂いたDictionary案コード実行いたしました。
仰る通り1秒未満でしたが、???さんの仰る通り、完全一致のみの検索となります。

※私が急ぎで書き載せてしまったサンプル例(部分一致にしていない)が悪く、
　βさんに誤解を与えてしましましたので、申し訳ございません

???の仰る方法か、後は比較件数を分割するか、
夜通し動かすかアナログな方法くらいでしょうか。。。

お二人ともありがとうございました。

（BK） 2016/07/28(木) 11:20

 >>完全一致のみの検索となります。

 はい。元コードを忠実に継承しましたので。

 >>夜通し動かすかアナログな方法くらいでしょうか。。。

 正規表現チェックを行えば、たぶん短い時間の処理で可能だと思います。
 ちょっと、書いてみて、結果がよければアップします。

（β） 2016/07/28(木) 12:46

 ちょこっと書いて動かしてみました。
 データは、同じ３０万件、５千件。部分一致件数も同じく１２万件ぐらい。

 さすがに時間がかかりますねぇ。（私のコードがおそまつなのかもしれませんが）

 Dictionaryだけで1秒弱だったんですが、正規表現をからめると　配列に格納するのに 21秒もかかりました。
 もう少し、やりくりしてみて、さまになればアップしますが、さすがに 21秒だと、かっこわるいので現段階のコードアップは
 控えます。

（β） 2016/07/28(木) 14:02

DB案です。サーバを立てると環境構築が面倒なので、ここは簡単に、シート自体をDB扱いする方法にしてみました。
Sheet1のA～C列1行目には、タイトル文字として、"A列"、"B列"、"C列" と入力されていて、2行目以降がデータであるものとします。
（シートをDB扱いする場合、項目名を表す文字列は1行目であること必須です）

部分一致があれば、Sheet1のC列に、Sheet2のB列を代入するロジックです。
大量のデータでは試験していませんので、是非お試しください。

 Sub test()
    Dim wk1 As Worksheet
    Dim wk2 As Worksheet
    Dim CN As Object
    Dim strSQL As String
    Dim i As Long

    Application.ScreenUpdating = False

    Set wk1 = Sheets("Sheet1")
    Set wk2 = Sheets("Sheet2")

    Set CN = CreateObject("ADODB.Connection")

    CN.Provider = "Microsoft.ACE.OLEDB.12.0"
    CN.Properties("Extended Properties") = "Excel 12.0"
    CN.Open ThisWorkbook.FullName

    With wk2
        For i = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
            strSQL = "UPDATE [Sheet1$] SET C列='" & .Cells(i, "B").Value & _
                     "' WHERE B列 LIKE '%" & .Cells(i, "A").Value & "%';"
            CN.Execute strSQL
        Next i
    End With

    Set CN = Nothing
    Application.ScreenUpdating = True
 End Sub
（???） 2016/07/28(木) 17:31

 いろいろやってみましたが３０万件/５千件で21秒から改善することはできていません。
 とりあえず、参考までにコードをアップしておきます。
 以下の、テストデータ作成部分は、こちらで、シート上にランダムに文字列をセットしたものから配列に
 収めているところで無視してください。
 実際の処理は、その下の部分です。

 Sub Test()
    Dim t As Double
    Dim Data1 As Variant
    Dim Data2 As Variant
    Dim OutData As Variant
    Dim reg As Object
    Dim dic As Object
    Dim i As Variant
    Dim mt As Object

    'テストデータ作成
    Data1 = Sheets("Sheet1").Range("A1:B300000").Value
    Data2 = Sheets("Sheet2").Range("A1:B5000").Value
    ReDim OutData(1 To UBound(Data1, 1), 1 To UBound(Data1, 2))
    'テストデータ作成終了

    'ここから処理

    t = Timer

    Set dic = CreateObject("Scripting.Dictionary")
    Set reg = CreateObject("VBScript.RegExp")
    reg.Global = True
    reg.Pattern = "([$()|\-\^\\[\]{}+*?.])"

    For i = 1 To UBound(Data2, 1)
        dic(Data2(i, 1)) = Data2(i, 2)
    Next

    reg.Pattern = Replace(reg.Replace(Join(dic.keys, vbTab), "\$1"), vbTab, "|")
    reg.Global = False

    For i = 1 To UBound(Data1, 1)
        Set mt = reg.Execute(Data1(i, 1))
        If mt.Count > 0 Then
            OutData(i, 1) = dic(mt(0).Value)
        End If
    Next

    MsgBox Timer - t

 End Sub

（β） 2016/07/28(木) 18:22

βさん、???さんご回答ありがとうございます。

本日は時間があまり無かったため、
一旦、βさんの正規表現案を稼働させてみました。

テスト的に30万件×1000件で行い、処理的には3分くらいでした。
しかしながら、マッチするはずのものがマッチしなかったため、
中身を確認する状態です。

取り急ぎご連携までです。

（BK） 2016/07/29(金) 18:16

 >>しかしながら、マッチするはずのものがマッチしなかったため

 ありえますね、それは。

 膨大な件数の処理時間の圧縮を中心にコードを組み立て、そこでのアプリ要件は、BKさんが仮に書かれた
 完全一致処理コードから推測していますので、こちらの要件理解ミスもあるかと思います。

 処理時間に、ある程度のめどがつけば、今度は、マッチするはずなのにマッチしないといったデータを中心に
 Sheet1 も Sheet2 も 10件程度のデータにして実行してみませんか？

 そこで、このデータは、マッチしてこうなるはずだけど、マッチしなかったといった具体的な情報をいただければ
 今度は、アプリロジックの正常化に注力するお手伝いもできるかと思います。

（β） 2016/07/29(金) 19:34

 ちなみに

 ●Sheet1

     |[A]              |[B]
 [1] |a1               |b1 
 [2] |a2               |b2 
 [3] |もしかしてcccかな|b3 
 [4] |a4               |b4 
 [5] |a5               |b5 
 [6] |aaaだよ          |b6 
 [7] |a7               |b7 
 [8] |a8               |b8 
 [9] |これはbbb        |b9 
 [10]|a10              |b10

 ●Sheet2

     |[A]|[B]    
 [1] |x1 |y1     
 [2] |x2 |y2     
 [3] |aaa|結果aaa
 [4] |x4 |y4     
 [5] |x5 |y5     
 [6] |ccc|結果ccc
 [7] |x7 |y7     
 [8] |bbb|結果bbb
 [9] |x9 |y9     
 [10]|x10|y10

 こんなデータをつくリ、アップ済みのコードの配列を小さくしたもので最後に結果をSheet1のC列に落としこんでみると

 ●Sheet1結果

     |[A]              |[B]|[C]    
 [1] |a1               |b1 |       
 [2] |a2               |b2 |       
 [3] |もしかしてcccかな|b3 |結果ccc
 [4] |a4               |b4 |       
 [5] |a5               |b5 |       
 [6] |aaaだよ          |b6 |結果aaa
 [7] |a7               |b7 |       
 [8] |a8               |b8 |       
 [9] |これはbbb        |b9 |結果bbb
 [10]|a10              |b10|

 こんなようになっています。

（β） 2016/07/29(金) 19:50

βさんご回答ありがとうございます。
遅くなり申し訳ございません。

結果として・・・βさんのコードで全く問題ありませんでした。
途中で仕様変更などして、私が少し間違えていました。(最終以下のデータ＆コードとなりました)
ご報告も含めまして、簡単ですがUPしておきます。

【仕様】
DataSheetのNAMEと各検索シート(CharaSheet@)の検索ｷｰをマッチングさせ、
マッチしたら出力結果を処理結果に出力する。
尚、検索シートは優先順位があり、例えば以下のﾏｯﾁ1やﾏｯﾁ2は多数ヒットするため、
優先順位を下げるために検索シートの後方へ設定。
逆に単独ヒットする分は優先度の高い検索シートへ記載。
※尚～の仕様は当方の都合ですので無視して頂いて可

【データ／処理結果】

DataSheet(処理結果含め)
CODE NAME 処理結果
A00001 ﾃﾞｰﾀﾏｯﾁ1 結果ﾏｯﾁ1
A00002 ﾃﾞｰﾀﾏｯﾁ2 結果ﾏｯﾁ2
A00003 ﾃﾞｰﾀﾏｯﾁ3 結果ﾏｯﾁ3
A00004 ﾃﾞｰﾀﾏｯﾁ4 結果ﾏｯﾁ4
A00005 ﾃﾞｰﾀﾏｯﾁ5 結果ﾏｯﾁ5
A00006 ﾃﾞｰﾀﾏｯﾁ6 結果ﾏｯﾁ6
A00007 ﾃﾞｰﾀﾏｯﾁ7 結果ﾏｯﾁ7
A00008 ﾃﾞｰﾀﾏｯﾁ8 結果ﾏｯﾁ8
A00009 ﾃﾞｰﾀﾏｯﾁ9 結果ﾏｯﾁ9
A00010 (ﾃﾞｰﾀﾏｯﾁ10) 結果ﾏｯﾁ10
A00011 (ﾃﾞｰﾀﾏｯﾁ11) 結果ﾏｯﾁ11
A00012 (ﾃﾞｰﾀﾏｯﾁ12) 結果ﾏｯﾁ12
A00013 (ﾃﾞｰﾀﾏｯﾁ13) 結果ﾏｯﾁ13
A00014 (ﾃﾞｰﾀﾏｯﾁ14) 結果ﾏｯﾁ14
A00015 (ﾃﾞｰﾀﾏｯﾁ15) 結果ﾏｯﾁ15
A00016 (ﾃﾞｰﾀﾏｯﾁ16) 結果ﾏｯﾁ16
A00017 (ﾃﾞｰﾀﾏｯﾁ17) 結果ﾏｯﾁ17
A00018 (ﾃﾞｰﾀﾏｯﾁ18) 結果ﾏｯﾁ18
A00019 (ﾃﾞｰﾀﾏｯﾁ19) 結果ﾏｯﾁ19
A00020 ﾃﾞｰﾀ (ﾏｯﾁ20) 結果(ﾏｯﾁ20)
A00021 ﾃﾞｰﾀ (ﾏｯﾁ21) 結果(ﾏｯﾁ21)
A00022 ﾃﾞｰﾀ (ﾏｯﾁ22) 結果(ﾏｯﾁ22)
A00023 ﾃﾞｰﾀ (ﾏｯﾁ23) 結果(ﾏｯﾁ23)
A00024 ﾃﾞｰﾀ (ﾏｯﾁ24) 結果(ﾏｯﾁ24)
A00025 ﾃﾞｰﾀ (ﾏｯﾁ25) 結果(ﾏｯﾁ25)
A00026 ﾃﾞｰﾀ (ﾏｯﾁ26) 結果(ﾏｯﾁ26)
A00027 ﾃﾞｰﾀ (ﾏｯﾁ27) 結果(ﾏｯﾁ27)
A00028 ﾃﾞｰﾀ (ﾏｯﾁ28) 結果(ﾏｯﾁ28)
A00029 ﾃﾞｰﾀ (ﾏｯﾁ29) 結果(ﾏｯﾁ29)
A00030 ﾃﾞｰﾀ (ﾏｯﾁ30) 結果(ﾏｯﾁ30)
A00031 ﾃﾞｰﾀｱﾝﾏｯﾁ1 結果ﾏｯﾁ1
A00032 ﾃﾞｰﾀｱﾝﾏｯﾁ2 結果ﾏｯﾁ2
A00033 ﾃﾞｰﾀｱﾝﾏｯﾁ3 結果ﾏｯﾁ3
A00034 ﾃﾞｰﾀｱﾝﾏｯﾁ4 結果ﾏｯﾁ4
A00035 ﾃﾞｰﾀｱﾝﾏｯﾁ5 結果ﾏｯﾁ5
A00036 ﾃﾞｰﾀｱﾝﾏｯﾁ6 結果ﾏｯﾁ6
A00037 ﾃﾞｰﾀｱﾝﾏｯﾁ7 結果ﾏｯﾁ7
A00038 ﾃﾞｰﾀｱﾝﾏｯﾁ8 結果ﾏｯﾁ8
A00039 ﾃﾞｰﾀｱﾝﾏｯﾁ9 結果ﾏｯﾁ9
A00040 ﾃﾞｰﾀｱﾝﾏｯﾁ10 結果ｱﾝﾏｯﾁ
A00041 ﾃﾞｰﾀｱﾝﾏｯﾁ11 結果ｱﾝﾏｯﾁ
A00042 ﾃﾞｰﾀｱﾝﾏｯﾁ12 結果ｱﾝﾏｯﾁ
A00043 ﾃﾞｰﾀｱﾝﾏｯﾁ13 結果ｱﾝﾏｯﾁ
A00044 ﾃﾞｰﾀｱﾝﾏｯﾁ14 結果ｱﾝﾏｯﾁ
A00045 ﾃﾞｰﾀｱﾝﾏｯﾁ15 結果ｱﾝﾏｯﾁ
A00046 ﾃﾞｰﾀｱﾝﾏｯﾁ16 結果ｱﾝﾏｯﾁ
A00047 ﾃﾞｰﾀｱﾝﾏｯﾁ17 結果ｱﾝﾏｯﾁ
A00048 ﾃﾞｰﾀｱﾝﾏｯﾁ18 結果ｱﾝﾏｯﾁ
A00049 ﾃﾞｰﾀｱﾝﾏｯﾁ19 結果ｱﾝﾏｯﾁ
A00050 ﾃﾞｰﾀｱﾝﾏｯﾁ20 結果ｱﾝﾏｯﾁ

CharaSheet1(検索シート1枚目)
検索ｷｰ　出力結果
ﾏｯﾁ10 結果ﾏｯﾁ10
ﾏｯﾁ11 結果ﾏｯﾁ11
ﾏｯﾁ12 結果ﾏｯﾁ12
ﾏｯﾁ13 結果ﾏｯﾁ13
ﾏｯﾁ14 結果ﾏｯﾁ14
ﾏｯﾁ15 結果ﾏｯﾁ15
ﾏｯﾁ16 結果ﾏｯﾁ16
ﾏｯﾁ17 結果ﾏｯﾁ17
ﾏｯﾁ18 結果ﾏｯﾁ18
ﾏｯﾁ19 結果ﾏｯﾁ19
(ﾏｯﾁ20) 結果(ﾏｯﾁ20)
(ﾏｯﾁ21) 結果(ﾏｯﾁ21)
(ﾏｯﾁ22) 結果(ﾏｯﾁ22)
(ﾏｯﾁ23) 結果(ﾏｯﾁ23)
(ﾏｯﾁ24) 結果(ﾏｯﾁ24)
(ﾏｯﾁ25) 結果(ﾏｯﾁ25)
(ﾏｯﾁ26) 結果(ﾏｯﾁ26)
(ﾏｯﾁ27) 結果(ﾏｯﾁ27)
(ﾏｯﾁ28) 結果(ﾏｯﾁ28)
(ﾏｯﾁ29) 結果(ﾏｯﾁ29)
(ﾏｯﾁ30) 結果(ﾏｯﾁ30)
ｱﾝﾏｯﾁ結果ｱﾝﾏｯﾁ

CharaSheet2(検索シート2枚目)
検索ｷｰ　出力結果
ﾏｯﾁ1 結果ﾏｯﾁ1
ﾏｯﾁ2 結果ﾏｯﾁ2
ﾏｯﾁ3 結果ﾏｯﾁ3
ﾏｯﾁ4 結果ﾏｯﾁ4
ﾏｯﾁ5 結果ﾏｯﾁ5
ﾏｯﾁ6 結果ﾏｯﾁ6
ﾏｯﾁ7 結果ﾏｯﾁ7
ﾏｯﾁ8 結果ﾏｯﾁ8
ﾏｯﾁ9 結果ﾏｯﾁ9

【コード】上記に合わせてFindCellData＝各CharaSheetのデータ　DataSheetCellData＝DataSheetのデータ
Set Reg = CreateObject("VBScript.RegExp")
Reg.Global = True
Reg.Pattern = "([$()|\-\^\\[\]{}+*?.])"

Set FindDic = CreateObject("Scripting.Dictionary")

For J = 1 To UBound(FindCellData, 1)

    FindDic(FindCellData(J, 1)) = FindCellData(J, 2)
Next

Reg.Pattern = Replace(Reg.Replace(Join(FindDic.keys, vbTab), "\$1"), vbTab, "|")
Reg.Global = False

For J = 1 To UBound(DataSheetCellData, 1)

    Set Mt = Reg.Execute(DataSheetCellData(J, 2))
    If Mt.Count > 0 Then
        If Len(OutputData(J, 1)) = 0 Then
            OutputData(J, 1) = FindDic(Mt(0).Value)
        End If
    End If
DoEvents
Next

Set FindCellData = Nothing

βさんのおかげで形に出来ました。
補足情報としまして、本データ30万件+検索ｷｰ1000件(1ｼｰﾄのみ)では
7分45秒掛りましたが十分現実的ですので問題ありません。
長々となりましたが、ありがとうございました。
（BK） 2016/08/01(月) 18:54

コメント返信：

[ 一覧(最新更新順) ]

[[20160727182237]] 『VBA 配列内の比較 高速化』（BK） ページの最後に飛ぶ

[[20160727182237]]　『VBA　配列内の比較　高速化』（BK）　ページの最後に飛ぶ