[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]
『大量データの処理』（シンデレラボーイ）
Sheet1、B2以下にA列の型式から、Sheet2の型式を見に行き、B列の識別を返すために 下記の式を作りました。 しかし、Sheet1は約3万行、Sheet2は約1万7千行もあり、処理時間が30も秒かかります。 ISERRORを外したら半分になりますが、Sheet2に無い物が出てくる可能性があるために 仕方なしに入れています。 この手の計算が違う列でも沢山する必要があり、少しでも処理時間を短縮したい と思います。ご指導お願いします。 もう一つ、Sheet2に該当が無ければメッセージが出るよう、合わせてお願いします。
Sub Macro1()
myTime = Timer
Sheets("Sheet1").Select
B = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(2, 2), Cells(B, 2)) = "=IF(ISERROR(VLOOKUP(A2,Sheet2!A:B,2,0)),"""",(VLOOKUP(A2,Sheet2!A:B,2,0)))"
Range(Cells(2, 2), Cells(B, 2)).Value = Range(Cells(2, 2), Cells(B, 2)).Value
MsgBox Format(Timer - myTime, "#,##0.00") & "秒かかりました。"
End Sub
【Sheet1】 【Sheet2】
A B A B
1 型式 識別 型式 識別
2 AB AB V
3 CD CD G
4 EF EF K
5 GH GH F
6 IJ JK M
＜ 使用 Excel：Excel2007、使用 OS：Windows7 ＞
以下で試してみてください。
Sub Test()
Dim dic As Object
Dim c As Range
Dim t As Double
Dim w As Variant
Dim x As Long
t = Timer
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet2")
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
dic(c.Value) = c.Offset(, 1).Value
Next
End With
With Sheets("Sheet1")
With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
ReDim w(1 To .Rows.Count, 1 To 1)
For Each c In .Cells
x = x + 1
w(x, 1) = dic(c.Value)
Next
.Offset(, 1).Value = w
End With
End With
MsgBox Timer - t
End Sub
（β） 2015/07/25(土) 21:52
>>もう一つ、Sheet2に該当が無ければメッセージが出るよう、合わせてお願いします。 これは未対応です。メッセージですか？ それともセルに"該当なし"とか？ メッセージだとして、各行、その都度ですか？ それとも最後にまとめて？
（β） 2015/07/25(土) 21:54
マナさんありがとうございます。以下、IFERRORでやってみましたがエラーが出ます。 Sub Macro2()
myTime = Timer
Sheets("Sheet1").Select
B = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(2, 2), Cells(B, 2)) = "=IFERROR(VLOOKUP(A2,Sheet2!A:B,2,0)"
Range(Cells(2, 2), Cells(B, 2)).Value = Range(Cells(2, 2), Cells(B, 2)).Value
MsgBox Format(Timer - myTime, "#,##0.00") & "秒かかりました。"
End Sub
βさん、ご指導ありがとうございます。 早速、実行してみました。恐るべし、0.4秒で完了しました。 是非習得したいです!!! メッセージですが、エラーが発生した時点で、メッセージで"該当なし"としたいです。 よろしくお願いします。 （シンデレラボーイ） 2015/07/25(土) 22:20
Test2 は、その都度メッセージ、Test3は、最後にまとめて。 いずれも時間計測は取り除いています。
7/26 5:21 Test2に１コード追加。
Sub Test2()
Dim dic As Object
Dim c As Range
Dim w As Variant
Dim x As Long
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet2")
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
dic(c.Value) = c.Offset(, 1).Value
Next
End With
With Sheets("Sheet1")
With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
ReDim w(1 To .Rows.Count, 1 To 1)
For Each c In .Cells
x = x + 1
If dic.exists(c.Value) Then
w(x, 1) = dic(c.Value)
Else
Application.Goto c
.Offset(, 1).Value = w
MsgBox c.Value & " の登録がありません"
End If
Next
.Offset(, 1).Value = w
End With
End With
End Sub
Sub Test3()
Dim dic As Object
Dim c As Range
Dim w As Variant
Dim x As Long
Dim r As Range
Dim er As Variant
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("Sheet2")
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
dic(c.Value) = c.Offset(, 1).Value
Next
End With
With Sheets("Sheet1")
With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
ReDim w(1 To .Rows.Count, 1 To 1)
For Each c In .Cells
x = x + 1
If dic.exists(c.Value) Then
w(x, 1) = dic(c.Value)
Else
If IsArray(er) Then
ReDim Preserve er(1 To UBound(er) + 1)
Else
ReDim er(1 To 1)
End If
er(UBound(er)) = c.Value
End If
Next
.Offset(, 1).Value = w
End With
End With
If IsArray(er) Then MsgBox "以下の値の登録がありませんでした" & vbLf & Join(er, vbLf)
End Sub
（β） 2015/07/25(土) 22:54
βさん、メッセージありがとうございました。 都度と最後に、二通り。しかも型番名も出て来ます。 素晴らしいです。 感謝です。ありがとうございました。 （シンデレラボーイ） 2015/07/26(日) 07:42
ご指導いただきました、Sheet1 B列識別を、Sheet2から抽出することが出来たのですが、 ここからさらに、識別の担当者をSheet3 H列を見に行き、 Sheet1 C列に抽出したいです。 再度ご指導お願い致します。
【Sheet1】 【Sheet2】 【Sheet3】
A B C A B H I
1 型式 識別 担当 型式 識別 識別 担当
2 AB V AB V V 田中
3 CD G CD G G 鈴木
4 EF K EF K K 森
5 GH F GH F F 石田
6 IJ M JK M M 伊藤
（シンデレラボーイ） 2015/07/26(日) 23:48
メッセージは Test3スタイル。識別コードVS担当者、型式VS識別コードの２つにわけて表示します。 エラー表示が２種類になったので、従来の配列格納から、簡単なDictionary格納にかえました。
Sub Test4()
Dim dic As Object
Dim dicP As Object
Dim dicER As Object
Dim c As Range
Dim w As Variant
Dim x As Long
Dim r As Range
Dim er As Variant
Set dic = CreateObject("Scripting.Dictionary")
Set dicP = CreateObject("Scripting.Dictionary")
Set dicER = CreateObject("Scripting.Dictionary")
With Sheets("Sheet3")
For Each c In .Range("H2", .Range("H" & Rows.Count).End(xlUp))
dicP(c.Value) = c.Offset(, 1).Value
Next
End With
With Sheets("Sheet2")
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
dic(c.Value) = c.Offset(, 1).Value
If Not dicP.exists(c.Value) Then
dicER(dicER.Count) = c.Value
End If
Next
End With
If dicER.Count > 0 Then MsgBox "以下の識別コードに対する担当者の登録がありませんでした" & vbLf & Join(dicER.items, vbLf)
dicER.RemoveAll
With Sheets("Sheet1")
With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
ReDim w(1 To .Rows.Count, 1 To 2)
For Each c In .Cells
x = x + 1
If dic.exists(c.Value) Then
w(x, 1) = dic(c.Value)
w(x, 2) = dicP(dic(c.Value))
Else
dicER(dicER.Count) = c.Value
End If
Next
.Offset(, 1).Resize(, 2).Value = w
End With
End With
If dicER.Count > 0 Then MsgBox "以下の担当者に対する識別コードの登録がありませんでした" & vbLf & Join(dicER.items, vbLf)
End Sub
（β） 2015/07/27(月) 06:12
一回の検索で検索値を見つけ出すことを追求した性能の良いハッシュ法を使ったDictionaryには、 検索時間では、敵いませんが、
Range(Cells(2, 2), Cells(B, 2)) = "=IF(ISERROR(VLOOKUP(A2,Sheet2!A:B,2,0)),"""",(VLOOKUP(A2,Sheet2!A:B,2,0)))"
この手法でもうまく数式を使えば、敵わないまでも健闘することはできます。
新規ブックにて（Sheet1、Sheet2が存在する）、
標準モジュール（Module1）にサンプルデータ作成機能
Option Explicit
Sub Mk_Sample()
Const sh2num = 17000
Const sh1num = 30000
Dim smp As Variant
Dim g0 As Long
smp = Array("a", "b", "c", "d", "e", "f", "g", "h", "i", "j", "k", "l", "m", "n", "o", "p", "q", "r", "s", "t", "u", "v", "w", "x", "y", "z")
With Worksheets("sheet2")
.Cells.Clear
.Range("a1:b1").Value = Array("型式", "識別")
g0 = 2
.Cells(g0, "a").Value = get_文字列(smp, 4)
Do While g0 <= sh2num
g0 = g0 + 1
.Cells(g0, "a").Value = get_文字列()
Loop
With .Range("b2:b" & (sh2num + 1))
.Formula = "=mid(a2,1,2)&row()"
.Value = .Value
End With
End With
With Worksheets("sheet1")
.Cells.Clear
.Range("a1:b1").Value = Array("型式", "識別")
With .Range("a2:a" & sh1num)
.Formula = "=index(sheet2!$a$2:$a$" & (sh2num + 1) & ",int(rand()*" & sh2num & ")+1,1)"
.Value = .Value
End With
End With
End Sub
Function get_文字列(Optional myarray As Variant, Optional num As Long = 0) As Variant
Dim g0 As Long
Static mary As Variant
Static idx As Long
Static svnum As Long
Dim g1 As Long
If num > 0 Then
svnum = num
idx = 0
mary = myarray
End If
g1 = idx
For g0 = 1 To svnum
get_文字列 = mary(g1 Mod (UBound(mary) - LBound(mary) + 1)) & get_文字列
g1 = g1 \ (UBound(mary) - LBound(mary) + 1)
Next
idx = idx + 1
End Function
上記のMk_Sampleを実行してください。
Sheet2には、型式、識別のマスターデータのサンプルが作成されます。
17000行作成されています。この数が多いほど、Dictionaryに迫ることができます。 (sh2numを変更すれば 行数は増やせます）。
尚、型式は、昇順にソートされています（ここがポイント）。
Sheet1には、検索処理を行うサンプルデータが30000行作成されています。
この識別をSheet2の型式から検索します。
標準モジュール（Module2）に
Option Explicit
Sub test1()
Const fcol = 26
Dim mytime As Double
Dim B As Long
Dim rng As Range
mytime = Timer
Application.Calculation = xlAutomatic
Application.ScreenUpdating = False
Sheets("Sheet1").Select
B = Worksheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row
Range(Cells(2, fcol), Cells(B, fcol)).Formula = "=a2=index(sheet2!a:a,match(A2,Sheet2!A:a,1),1)"
With Range(Cells(2, "b"), Cells(B, "b"))
.Formula = "=if(z2, vlookup(a2,sheet2!a:b,2,true),na())"
On Error Resume Next
Set rng = .SpecialCells(xlCellTypeFormulas, xlErrors)
If Err.Number = 0 Then
rng.Value = ""
End If
On Error GoTo 0
.Value = .Value
.Offset(0, fcol - 2).Clear
End With
Application.ScreenUpdating = True
MsgBox Format(Timer - mytime, "#,##0.00") & "秒かかりました。"
If Not rng Is Nothing Then MsgBox "エラーセル " & rng.Offset(0, -1).Address
End Sub
test1を実行してみてください。 尚、作業列として、Ｚ列を使っています。
シンデレラボーイさんのVlookupは、逐次検索ですが、上記の例は、バイナリサーチの手法を使った Vlookupを使っています。
（ichinose@暑いですねえ） 2015/07/27(月) 19:19
βさん、確認しました。ありがとうございました。 【Sheet1】の識別列がFになった場合どこを替えたらいいですか？ ご教示おねがいします。
【Sheet1】 【Sheet2】 【Sheet3】
A B C D E F G A B H I
1 型式 識別 担当 型式 識別 識別 担当
2 AB V AB V V 田中
3 CD G CD G G 鈴木
4 EF K EF K K 森
5 GH F GH F F 石田
6 IJ M JK M M 伊藤
ichinoseさん、私にはハードルが高いように思いますが、じっくり見させていただきます。 ありがとうございました。 （シンデレラボーイ） 2015/07/28(火) 06:57
With Sheets("Sheet1")
With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
ReDim w(1 To .Rows.Count, 1 To 2)
For Each c In .Cells
x = x + 1
If dic.exists(c.Value) Then
w(x, 1) = dic(c.Value)
w(x, 2) = dicP(dic(c.Value))
Else
dicER(dicER.Count) = c.Value
End If
Next
.Offset(, 1).Resize(, 2).Value = w
End With
End With
この最後の .Offset(, 1).Resize(, 2).Value = w これで、２列分の結果を転記しています。 基準として処理している列はA列です。なので、.Offset(,1) つまり、A列から右に１つすすんだ列、つまりB列（と、Resizeで２列にしていますから C列も）に 転記されることになっています。
これが B,C ではなく F,G ですから、Aから見れば右に5つ進んだところという指定をすればいいわけです。
ということで、 .Offset(, 5).Resize(, 2).Value = w になります。
で、結果を （β） 2015/07/28(火) 08:21
βさん、うまくいきました。ありがとうございました。 Sheet2、Sheet3から、Sheet4、Sheet5と、この手の抽出が続きます。 帰宅後、できるかどうか不安ですがやってみます。
（シンデレラボーイ） 2015/07/29(水) 08:55
不安的中です。色々とやってはみたのですが、変数の使い方がまずいのか、インデックスが有効範囲に ありません。で苦しんでいます。
小出しにして申し訳ありません。 【Sheet1】E列の営業所CDを 【Sheet3】A列B列から【Sheet1】H列 営業所に抽出したいのですが 再度ご指導よろしくお願いいたします。
【Sheet1】 【Sheet2】 【Sheet3】
A E F G H A B A B H I
1 型式 営業所CD 識別 担当 営業所 型式 識別 営業所CD 営業所 識別 担当
2 AB Q10 V 田中 AB V Q10 東京 V 田中
3 CD Q11 G 鈴木 CD G Q11 大阪 G 鈴木
4 EF Q12 K 森 EF K Q12 神戸 K 森
5 GH Q13 F 石田 GH F Q13 広島 F 石田
6 IJ Q14 M 伊藤 JK M Q14 福岡 M 伊藤
（シンデレラボーイ） 2015/07/31(金) 21:16
>>Sheet2、Sheet3から、Sheet4、Sheet5と、この手の抽出が続きます。
ということだったのですが、そうではない？ 実際に存在するデータに対して、要件を追加していきたいという感じじゃない印象ですねぇ・・・ レイアウトそのものも試行錯誤で検討中ということでしょうかねぇ？
まぁ、新規要件だということだと受け取れば、なんてことはないけど、どうも？？？？
愚痴はやめましょうかね。
質問。
Sheet1に最初に記載されているのは A列だけですか？ それとも A列、E列が記載されている？
別の言い方をします。
Sheet3 の情報のキーは H列（識別）で、識別ごとに、営業所CD,営業所、担当が紐付いて登録されている？ それとも、A列、B列 の固まり（リスト）と H列、I列の固まり（リスト）は全く別物？
（β） 2015/07/31(金) 23:47
βさん、本当に申し訳ありません。 抽出はSheet1 F列識別と、G列担当、H列営業所です。
F列識別は、Sheet1A列を基準にSheet2のA列B列から。 G列担当は、Sheet1F列を基準にSheet3のH列I列から。 H列営業所は、Sheet1E列を基準にSheet3のA列B列からです。 情報のキー（リスト)は単体で皆別物です。 どうかよろしくお願いいたします。 （シンデレラボーイ） 2015/08/01(土) 00:25
構成を若干変えています。未登録エラーは、最後にまとめてカテゴリー別に表示します。
Sub Test5()
Dim dicS As Object
Dim dicP As Object
Dim dicD As Object
Dim erS As Object
Dim erP As Object
Dim erD As Object
Dim c As Range
Dim w As Variant
Dim x As Long
Dim r As Range
Dim er As Variant
Set dicS = CreateObject("Scripting.Dictionary")
Set dicP = CreateObject("Scripting.Dictionary")
Set dicD = CreateObject("Scripting.Dictionary")
Set erS = CreateObject("Scripting.Dictionary")
Set erP = CreateObject("Scripting.Dictionary")
Set erD = CreateObject("Scripting.Dictionary")
With Sheets("Sheet3")
'識別/担当
For Each c In .Range("H2", .Range("H" & Rows.Count).End(xlUp))
dicP(c.Value) = c.Offset(, 1).Value
Next
'営業所CD/営業所
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
dicD(c.Value) = c.Offset(, 1).Value
Next
End With
With Sheets("Sheet2")
'型式/識別
For Each c In .Range("A2", .Range("A" & Rows.Count).End(xlUp))
dicS(c.Value) = c.Offset(, 1).Value
Next
End With
'転記
With Sheets("Sheet1")
With .Range("A2", .Range("A" & Rows.Count).End(xlUp))
ReDim w(1 To .Rows.Count, 1 To 3)
For Each c In .Cells
x = x + 1
w(x, 1) = dicS(c.Value) '型式->識別
w(x, 2) = dicP(dicS(c.Value)) '識別->担当
w(x, 3) = dicD(c.Offset(, 4).Value) '営業所CD->営業所
If IsEmpty(w(x, 1)) Then erS(c.Value) = True
If IsEmpty(w(x, 2)) And Not IsEmpty(dicS(c.Value)) Then erP(dicS(c.Value)) = True
If IsEmpty(w(x, 3)) Then erD(c.Offset(, 4).Value) = True
Next
.Offset(, 5).Resize(, 3).Value = w
End With
End With
If erS.Count > 0 Then MsgBox "以下の型式に対する識別コードの登録がありませんでした" & vbLf & Join(erS.keys, vbLf)
If erP.Count > 0 Then MsgBox "以下の識別に対する担当の登録がありませんでした" & vbLf & Join(erP.keys, vbLf)
If erD.Count > 0 Then MsgBox "以下の営業所CDに対する営業所の登録がありませんでした" & vbLf & Join(erD.keys, vbLf)
End Sub
（β） 2015/08/01(土) 06:57
追加（？）で。
ichinoseさんの回答、時間があれば是非、試して「味わってみてください」 VBAに限らず、シート上で関数を記述する場合でも、VLOOKUPやMATCHといった検索系の関数の場合 照合の型（検索の型）で、FALSE あるいは 0 といったものを指定して、直接（逐次）照合を行うことが 多いのですが、処理効率からいえば、リストそのものを昇順にしておいて TRUE あるいは 1 と指定すると 裏側ではきわめて効率のいい「二分検索」が実行されます。直接検索に比べ、検索結果が妥当かどうかの 判定をひと手間加える必要があるのですが、「上級者アルゴリズム」となります。
別の板ですが、その昔、βがひよっこだったころ、怖い回答者さんがいらっしゃって、Dictionaryで回答案を出すたびに
「初心者ならバカチョンDictionaryの使用は目をつぶるが、ちゃんと、二分検索を使い、自分でまともなアルゴリズムを組み立てろ！」
と、叱られましたね。
ましてや、照合型 0 の MATCH を使おうものなら、「バカMATCHを使うのはバカ」と。（今思い出しても怖い先生でした。）
（β） 2015/08/01(土) 07:11
βさん、思いどおりのものになっています。ありがとうございました。 今回は至らぬ点、わかりにくいリストなど、多々ありながらも手厚い対応に感謝しています。 ご察しのとおりですが、とにかく勉強不足です。 ichinoseさんからの、教えもじっくりやっていきたいと思います。 ありがとうございました。
（シンデレラボーイ） 2015/08/01(土) 08:01
ズーッと昔、テニスのデカラケが出始めた頃、 コーチ連は、「初心者の内はそれを使うのもいいでしょう。 でも慣れてきたら、レギュラーサイズに戻した方がいいでしょう」 とか言っていました。
今や誰もが常時デカラカを使っています。プロでも珍しくない。
当時のコーチ連の見識は、どんなもんなんですかね。
（半平太） 2015/08/01(土) 14:47
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.