マクロVLOOKUPの高速化

質問

シート１には13,000行、
シート区分マスターには25,000行において
シート１の検索値からシート区分マスターを検索して
ヒットしたらシート１に返したいです。
シート１のデータ行文行いたいです。
シート１の行数は常に変化、
シート区分マスターの行数は固定です。

以下の記述で検索を行いますが終了するのに
５分強かかります。
（下のほうに再計算０％→５％→７０％→９５％と表示されている）
もっと早く処理させる方法はありますでしょうか？
よろしくお願いします。

Sub 区分検索()

'2010 年11月18日
'シート１のＡ列を検索値として
'シート区分マスターのＡ列を検索しヒットしたら
'シート区分マスターの該当行のＥ列をシート１のＣ列に転記
'データはそれぞれのシートともに２列目からである
'ヒットしない場合はシート１のＣ列は空白にする

'検索値と転記するセルのシート選択
With Sheets("シート１")
'データ開始行のC2に式を入れる
.Range("C2").Formula = _
"=IF(ISNA(VLOOKUP(A2,区分マスター!$A:$E,5,FALSE)),"""",VLOOKUP(A2,区分マスター!$A:$E,5,FALSE))" '数式入力
'式によって抽出されてC列に転記された値をコピーします。
.Range("C2").Copy .Range("C2:C" & .Range("A" & .Rows.Count).End(xlUp).Row) 'データ最終行までコピー
.Columns("C:C").Copy
'コピーした値をC1から値貼付を行う
.Range("C1").PasteSpecial Paste:=xlPasteValues 'C列を値に変換
Application.CutCopyMode = False
End With
End Sub

回答No.7

end-u · ベストアンサー

元々、Sub dictest2()は、
VLOOKUPと同じ答えを出すと同時に、
"区分マスター"に重複がある、
という事をチェックしてもらう為に書いたものです。

例えば

Ａ列　Ｂ列
key 　item
a　　　1
b　　　2
c　　　3
a　　　4

このような『マスタ』で"a"をVLOOKUP検索すると
=VLOOKUP("a",A:B,2,0)
=1
となります。
先に見つかった"a"のitem 1 が答えです。

Sub dictest()では
>For i = 1 To UBound(v)
>　　dic(v(i, 1)) = i
>Next
この箇所で、dictionaryオブジェクトにkeyを登録してます。
上の例でいけば
"a","b","c","a"..です。
"a"が重複していた場合は後の"a"で【上書き】されます。
この時登録されるitemは 4 です。

だから、このような登録の仕方をすると
取り出されるkeyは、【後】から登録した"a"で、itemは 4 になります。

対して、Sub dictest2()では
>For i = 1 To UBound(v)
>　　'修正箇所
>　　If dic.exists(v(i, 1)) Then
>　　　　Debug.Print "重複", v(i, 1)
>　　Else
>　　　　dic(v(i, 1)) = w(i, 1)
>　　End If
>Next
この箇所で、dictionaryオブジェクトにkeyを登録してます。
If dic.exists(v(i, 1)) Then ...existsメソッドを使って、
keyが【既に】登録されていれば、
登録せずに[イミディエイトウィンドウ]に"重複"..と書き出します。
keyが未登録だったら登録します。

Sub dictest2()では
取り出されるkeyは、【前】に登録した"a"で、itemは 1 になります。

VLOOKUPと同じ動きをするのはSub dictest2()です。
『マスタ』に重複がなく、ユニークなkeyであれば
Sub dictest()もSub dictest2()も同じ結果になります。
速度的に有利なのはSub dictest()だと思います。

dictionaryオブジェクトを使ってデータ検索をする場合、
検索データが重複していた場合に、前優先か後優先かで
コードの書き方が変わります。
検索と同時に重複をチェックしたいなら、
Sub dictest2()のようにexistsメソッドを使います。

あるいはSub dictest()でkeyを登録する時に、逆にLoopすれば
：
For i = UBound(v) To 1 Step -1
　　dic(v(i, 1)) = i
Next
：
前優先になります。

結論として、
『マスタ』の重複はあり得ないのが基本だと思いますから、
Sub dictest()で良いはずです。

お礼

勉強してくださいね。とURLまで貼ってくれたのですが、
それを見てもいまいち理解できませんでした。

今回の回答で、やっと理解しました。
すごく分かりやすい説明で、嬉しかったです。

おかげでマスターがでたらめだった事がわかり大変感謝です。
セルにＶＬＯＯＫＵＰ式を入れて運用していたのですが
気がつきませんでした。

マクロでもＶＬＯＯＫＵＰ式を貼り付けるつもりでいたので
セルに式を入れたのと同じ結果のはずで
マスターの不備は気がつかなかったと思います。

高速化でアドバイスいただいた結果マスター不備にたどり着き
大変感謝です。

どうもありがとうございました。

回答No.6

end-u

>VLOOKUPで行った時と
>この記述で行った時で
>返ってきた値が相違する行が２，０００行ほどあります。
ありゃ。
そうですか。

Sub dictest2()
　　Dim dic As Object
　　Dim i　 As Long
　　Dim v, w
　　Dim t As Single

　　t = Timer
　　With Sheets("区分マスター")
　　　　With .Range("E2", .Cells(.Rows.Count, 1).End(xlUp))
　　　　　　v = .Columns(1).Value
　　　　　　w = .Columns(5).Value
　　　　End With
　　End With
　　Set dic = CreateObject("scripting.dictionary")
　　For i = 1 To UBound(v)
　　　　'修正箇所
　　　　If dic.exists(v(i, 1)) Then
　　　　　　Debug.Print "重複", v(i, 1)
　　　　Else
　　　　　　dic(v(i, 1)) = w(i, 1)
　　　　End If
　　Next
　　With Sheets("シート１")
　　　　With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
　　　　　　v = .Value
　　　　　　For i = 1 To UBound(v)
　　　　　　　　If dic.exists(v(i, 1)) Then
　　　　　　　　　　v(i, 1) = dic(v(i, 1))
　　　　　　　　Else
　　　　　　　　　　v(i, 1) = "無"
　　　　　　　　End If
　　　　　　Next
　　　　　　With .Offset(, 2)
　　　　　　　　.ClearContents
　　　　　　　　.Value = v
　　　　　　End With
　　　　End With
　　End With
　　Set dic = Nothing
　　Debug.Print Timer - t
End Sub

これでチェックしてください。
実行後、VBE画面[ctrl]+[g]キー。[イミディエイトウィンドウ]に
"重複" キーが書き出されてたら、Sheets("区分マスター")が重複してます。
"マスター"なのでキー重複はないと判断しましたが、
あれば、それも問題ですね。

お礼

どうもありがとうございました。

Sub dictest( )
→VLOOKUPで行った時と返ってきた値が相違する行が
　シート１の13,000行中、約2,000行ありました。

↓↓↓

Sub dictest2( )
→VLOOKUPで行った時と同一になりました。

　＞実行後、VBE画面[ctrl]+[g]キー。
　＞[イミディエイトウィンドウ]に
　＞"重複" キーが書き出されてたら、
　＞Sheets("区分マスター")が重複してます。

すでに解決（VLOOOKUPの時と同じになった）しましたが
念の為、上記内容を確認しました。

重複キーが出てきました。

「区分マスター」を調査したら
25,000行中Ａ列の値の重複が約11,000行もありました。

「区分マスター」を整理整頓し、Ａ列の値の重複は無しにしました。
結果　「区分マスター」は　25,000行 → 約14,000行 になりました。

この「区分マスター」修正後に
Sub dictest2( )をもう一度行ってみました。

→VLOOKUPで行った時と同一になりました。
→「区分マスター」修正前にSub dictest2( )で行った時と同じでした。

あれっ?と思い「区分マスター」修正後に
もう一度　Sub dictest( )　を試してみました。
→VLOOKUPで行った時と同一になりました。

原因は
「区分マスターに重複行があった為」みたいです。
　・Sub dictest2( )を作成していただかなくても大丈夫だった
になってしまいました。
大変申し訳ありませんでした。

教えていただいた
　・Sub dictest( )と
　・Sub dictest2( )なのですが

Sub dictest2( )は「区分マスター」に重複があっても
VLOOKUPと同じになるので
Sub dictest2( )を使用した方が安全でしょうか？

それとも「区分マスター」に重複があると
Sub dictest( )と
Sub dictest2( )のどちらでも、相違する値が出る可能性があるのでしょうか？

　（区分マスターが重複していればVLOOKUPで行った時の
　　返した値も信憑性がありません。
　　重複していても返す値のあるE列の値が同じならいいのですが相違すれば
　　どちらの値が返されるか分かりません。）

金曜日から混乱しています。お礼が遅れてしまいました。
申し訳ありません。

回答No.5

merlionXX

おはようございます、gx9wxさん。
一夜明けたら、わたしが常に尊敬するend-uさまから、驚異的なコードが提案されていますね！
VLOOKUP検索のかわりにDictionaryオブジェクトを使うなんて、これまで考えたこともなかった・・・。

2万行でためしたらわずか0.625秒！
比較にもなりません。
end-uさま、脱帽です。(o。_。)oペコッ

よい勉強をさせていただきました。

お礼

merlionXXさん。おはようございます。
merlionXXもありがとうございます。
いろいろ教えていただきました。
merlionXXに教えていただいた今までの物も
（このスレッド以外も含め）
私にとっては驚異的です。

さてend-uさんに教えていただいたこの記述ですが、
テストも終了しこれを使いたいと思います。
で例によって１行ごとに何をしているのか、これからコメントを入れていくのですが
完全にちんぷんかんぷんです。
URLも貼り付けてくれたのでにらめっこです。

回答No.4

end-u

>dictionaryオブジェクトを使ったりする事になります。
一応、サンプル書いておきますね。

Sub dictest()
　　Dim dic As Object
　　Dim i　 As Long
　　Dim v, w
　　Dim t As Single

　　t = Timer
　　With Sheets("区分マスター")
　　　　With .Range("E2", .Cells(.Rows.Count, 1).End(xlUp))
　　　　　　v = .Columns(1).Value
　　　　　　w = .Columns(5).Value
　　　　End With
　　End With
　　Set dic = CreateObject("scripting.dictionary")
　　For i = 1 To UBound(v)
　　　　dic(v(i, 1)) = i
　　Next
　　With Sheets("シート１")
　　　　With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
　　　　　　v = .Value
　　　　　　For i = 1 To UBound(v)
　　　　　　　　If dic.exists(v(i, 1)) Then
　　　　　　　　　　v(i, 1) = w(dic(v(i, 1)), 1)
　　　　　　　　Else
　　　　　　　　　　v(i, 1) = "無"
　　　　　　　　End If
　　　　　　Next
　　　　　　With .Offset(, 2)
　　　　　　　　.ClearContents
　　　　　　　　.Value = v
　　　　　　End With
　　　　End With
　　End With
　　Set dic = Nothing
　　Debug.Print Timer - t
End Sub

『vba scripting.dictionary』でnet検索して勉強してみてください。
http://www.eurus.dti.ne.jp/~yoneyama/Excel/vba/vba_dictionary.html

お礼

信じられません。
２６，０００行で1秒かかりませんでした。
会社にあるエクセルシートでマクロではなくセルに直接ｖｌｏｏｋｕｐの式を入れてある物
に流用したいと思います。
（ほとんどが15,000行を25,000行の中から検索で
　再計算とかで処理が重くて困っていました。）

どうもありがとうございました。

補足

申し訳ありません。
VLOOKUPで行った時と
この記述で行った時で
返ってきた値が相違する行が２，０００行ほどあります。
原因が分かりません。

多分と思われるのが
シート１の検索値（シート１のＡ列）に重複レコードがうじゃうじゃランダムに存在するという事くらいですが
重複していない1行のみしかいない行であっても
返ってきた値が相違しています。

回答No.3

end-u

VLookup自体が重いので、劇的に改善しようと思えば
dictionaryオブジェクトを使ったりする事になります。

Sub 区分検索02()を少しでも改善するなら
Sub test1()
　　Dim r　As Range
　　Dim ri As Range
　　Dim t As Single

　　t = Timer
　　Application.ScreenUpdating = False
　　Application.Calculation = xlCalculationManual

　　With Sheets("シート１")
　　　　Set r = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)).Offset(, 2)
　　End With
　　r.ClearContents
　　On Error Resume Next
　　For Each ri In r
　　　　ri.Value = WorksheetFunction.VLookup(ri.Offset(, -2), Worksheets("区分マスター").Range("A1:E60000"), 5, 0)
　　Next
　　On Error GoTo 0
　　r.Replace "", "無", xlWhole

　　Application.Calculation = xlCalculationAutomatic
　　Application.ScreenUpdating = True
　　Debug.Print Timer - t
End Sub

また、ApplicationレベルでVLookupを使って配列に対して処理をすると
環境によっては速く処理できます。
#Excel2000では配列制限があるためこのままでは使えないです。
Sub test2()
　　Dim v
　　Dim t As Single

　　t = Timer
　　With Sheets("シート１")
　　　　With .Range("A2", .Cells(.Rows.Count, 1).End(xlUp))
　　　　　　v = Application.VLookup(.Value, Worksheets("区分マスター").Range("A1:E60000").Value, 5, 0)
　　　　　　With .Offset(, 2)
　　　　　　　　.ClearContents
　　　　　　　　.Value = v
　　　　　　　　.Replace "#N/A", "無", xlWhole
　　　　　　End With
　　　　End With
　　End With
　　Debug.Print Timer - t
End Sub

お礼

ありがとうございます。
かなり早くなりました。
行数を倍にしても大丈夫です。

１．ここで教えていただいた表示と式停止の場合
　　13,500行＝1:49
　　27,000行＝3:35

２．質問後自作のLOOP文（記述は最後尾に）
　　13,500行＝1:00
　　27,000行＝1:58

３．今回教えていただいたSub test1()
　　13,500行＝0:58
　　27,000行＝1:54　

４．今回教えていただいたSub test2()
　　13,500行＝0:49
　　27,000行＝1:36　

質問では式を貼付して出た値を値貼付していた
↓
質問後自分で考えたloop文

Sub 区分検索02()

'2010 年11月18日
'シート１のＡ列を検索値として
'シート区分マスターのＡ列を検索しヒットしたら
'シート区分マスターの該当行のＥ列をシート１のＣ列に転記
'データはそれぞれのシートともに２列目からである
'ヒットしない場合はシート１のＣ列は空白にする

'検索値があるシート選択する
Sheets("シート１").Select
'そのシートの検索開始の行数を選択。2行目から開始。
Line = 2
'そのシートの検索値の列を指定1=A列。
'その値がなくなったら検索を終了させる。
Do Until Cells(Line, 1).Value = ""
'エラーとなっても次に進む
On Error Resume Next
'検索結果を転記する列を指定。Line3=C列
'検索するシートと列(1=A列）とヒットした場合のその行の返す値の列(5=E列）指定
Cells(Line, 3).Value = Application.WorksheetFunction.VLookup(Cells(Line, 1).Value, Worksheets("区分マスター").Range("A1:E60000"), 5, 0)
'VLOOKUP関数が終了又はエラーが発生したら止まる
On Error GoTo 0
'検索されなかったときの処理。
If Cells(Line, 3).Value = "" Then
Cells(Line, 3).Value = "無"
End If
'2行目から開始なので次の行の値を検索値とする
Line = Line + 1
'検索する値がなくなるまで繰返す
Loop
End Sub

補足

２０１０年１１月１９日　１２：００

申し訳ありません。
回答Ａ－ＮＯ．４の補足で間違いです。

＞VLOOKUPで行った時と
＞この記述で行った時で
＞返ってきた値が相違する行が２，０００行ほどあります。
＞原因が分かりません。

＞多分と思われるのが
＞シート１の検索値（シート１のＡ列）に重複レコードがうじゃうじゃランダムに存在するという事くらいですが
＞重複していない1行のみしかいない行であっても
＞返ってきた値が相違しています。

＞投稿日時 - 2010-11-19 11:51:18

重複レコードはありませんでした。
ですが
VLOOKUPで行った時と
この記述で行った時で
返ってきた値が相違する行が２，０００行ほどあります。

申し訳ありません。

回答No.2

merlionXX

画面停止だけじゃなく、計算停止も

Sub 区分検索02()
　　With Sheets("シート１")
　　　　Application.ScreenUpdating = False
　　　　Application.Calculation = xlCalculationManual
　　　　.Range("C2").Formula = _
　　　　"=IF(ISNA(VLOOKUP(A2,区分マスター!$A:$E,5,FALSE)),"""",VLOOKUP(A2,区分マスター!$A:$E,5,FALSE))"
　　　　.Range("C2").Copy .Range("C2:C" & .Range("A" & .Rows.Count).End(xlUp).Row)
　　　　Application.Calculation = xlCalculationAutomatic
　　　　.Columns("C:C").Copy
　　　　.Range("C1").PasteSpecial Paste:=xlPasteValues
　　　　Application.CutCopyMode = False
　　　　Application.ScreenUpdating = True
　　End With
End Sub

お礼

5分が2分になりました。
ありがとうございます。

質問しておいてなんですが、
行数からしてＬＯＯＰ文では絶対無理だと思いましたが
以下の記述だと１分で完了しました。
式を貼り付けて計算させて、でた値を値貼付するより
1行ごと処理する方が早いのでしょうか？？
それとも13,000行位だと、1行ごと処理の方が早く
行数がもっと増えるとこれでは遅くなるのでしょうか？
早く処理できたにはいいのですが記述に問題があるのか
確信がもてず不安です。

Sub 区分検索02()

'2010 年11月18日
'シート１のＡ列を検索値として
'シート区分マスターのＡ列を検索しヒットしたら
'シート区分マスターの該当行のＥ列をシート１のＣ列に転記
'データはそれぞれのシートともに２列目からである
'ヒットしない場合はシート１のＣ列は空白にする

'検索値があるシート選択する
Sheets("シート１").Select
'そのシートの検索開始の行数を選択。2行目から開始。
Line = 2
'そのシートの検索値の列を指定1=A列。
'その値がなくなったら検索を終了させる。
Do Until Cells(Line, 1).Value = ""
'エラーとなっても次に進む
On Error Resume Next
'検索結果を転記する列を指定。Line3=C列
'検索するシートと列(1=A列）とヒットした場合のその行の返す値の列(5=E列）指定
Cells(Line, 3).Value = Application.WorksheetFunction.VLookup(Cells(Line, 1).Value, Worksheets("区分マスター").Range("A1:E60000"), 5, 0)
'VLOOKUP関数が終了又はエラーが発生したら止まる
On Error GoTo 0
'検索されなかったときの処理。
If Cells(Line, 3).Value = "" Then
Cells(Line, 3).Value = "無"
End If
'2行目から開始なので次の行の値を検索値とする
Line = Line + 1
'検索する値がなくなるまで繰返す
Loop
End Sub

回答No.1

FEX2053

とりあえず、処理の前後に

Application.ScreenUpdating = False　/　True

を入れて、画面の逐次表示を止めて見たら？

お礼

教えていただいたとうりに行いましたが
やはり5分近くかかります。
どうもありがとうございました。