マクロdictionaryオブジェクト書換（続）

質問

以下のマクロがあります。
BOOK1で（Sub　CSV取得)を動作させると
選択したCSVファイルがBOOK2にインポートされて編集作業が行われる。

Sub　CSV取得（）
'選択したCSVファイルをインポートし
'シート名を集計にする。CSVファイルは閉じる。　
Call編集集計
End　Sub
---
Sub　編集集計（）
'BOOK2のシート集計の編集作業を行う
（途中記述省略）
Call 番号変更
（途中記述省略）
End Sub
---
Sub 番号変更()
'実験中。極遅。対策必要。
'BOOK2のシート集計のI列を検索値として
'BOOK1のシート新番号のA列を検索し
'ヒットしたらBOOK1のシート新番号の該当行のE列を
'BOOK2のシート集計のH列に転記する
'ヒットしない場合は　無　と転記する
'↑極遅の他にこれ（ヒットしない場合の処理）も
'正常動作しないので変更必要
Dim myBk As String
myBk = ThisWorkbook.Name
With Sheets("集計")
.Columns("H:H").NumberFormatLocal = "G/標準"
.Range("H1").Formula = _
"=IF(ISNA(VLOOKUP(I1,[" & myBk & "]新番号!$A:$E,5,FALSE)),I1,VLOOKUP(I1,[" & myBk & "]新番号!$A:$E,5,FALSE))"
.Range("H1").Copy .Range("H1:H" & .Range("I" & .Rows.Count).End(xlUp).Row)
.Columns("H:H").Copy
.Range("H1").PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
End With
End Sub
-----
とりあえずヒットしない場合以外は思ったとうり動いていますが、
・データが各シート20,000行を超える為３分～５分程度かかる。
・BOOK2のシート集計のI列とBOOK1のシート新番号のA列での
　検索ではデータの性質上、重複データがある事になってしまい
　返す値が違う場合が存在してしまいます。

よって高速な処理の以下↓の記述を応用し
かつ検索値も3つのセルの連結した値に変更に挑戦しギブアップです。
記述を教えてください。お願いします。

●やりたい事

BOOK2のシート集計のI,K,L列の順で連結した値を検索値として
BOOK1のシート新番号のA,B,C列の順で連結した値を検索し
ヒットしたらBOOK1のシート新番号の該当行のE列（セル書式標準半角英数字３ケタ）を
BOOK2のシート集計のH列に転記する。
ヒットしない場合は　無　と転記する。
BOOK2のシート集計はA列からO列でデータは1行目から。
BOKK1のシート新番号はA列からE列でデータは2行目から。
VLOOKUPは遅いので以下の記述を応用したい。
↓↓（応用の為の記載なので今回の希望処理の記述にはなっていません。）

----
Sub 検索02()
'VLOOKUPではなくdictionaryオブジェクトを使用
Dim dic As Object
Dim i As Long
Dim v, w
Dim t As Single
t = Timer
With Sheets("シート１")
With .Range("D2", .Cells(.Rows.Count, 1).End(xlUp))
v = .Columns(1).Value
w = .Columns(4).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("F2", .Cells(.Rows.Count, 6).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(, 25)
.ClearContents
.Value = v
End With
End With
End With
Set dic = Nothing
Debug.Print Timer - t
End Sub

回答No.3

merlionXX · ベストアンサー

> ２０秒くらいです。

う～ん、ちょいとストレスを感じる時間ですね。
そう思って、あなたの補足をよく見直してみたら重複があるのはSheets("集計")だけで、.Sheets("新番号")には重複がないんですね！
これを見逃していました。
だったら使えますよ、Dictionaryオブジェクトが。

というわけで、これでどうでしょう？
多分1秒もかからないのでは？

Sub TEST03()
　　Dim myV, myV2, myW, myW2
　　Dim i As Long, uw As Long, uv As Long
　　Dim myStr As String
　　Dim myDic As Object
　　With ThisWorkbook.Sheets("新番号")
　　　　myV = .Range("A2", .Cells(Rows.Count, "E").End(xlUp)).Value
　　End With
　　With Sheets("集計")
　　　　myW = .Range("I1", .Cells(Rows.Count, "L").End(xlUp)).Value
　　End With
　　uv = UBound(myV)
　　uw = UBound(myW)
　　ReDim myW2(1 To uw, 1 To 1) As String
　　Set myDic = CreateObject("Scripting.Dictionary")
　　For i = 1 To uv
　　　　myDic(myV(i, 1) & "!" & myV(i, 2) & "!" & myV(i, 3)) = myV(i, 5)
　　Next i
　　For i = 1 To uw
　　　　myStr = myW(i, 1) & "!" & myW(i, 3) & "!" & myW(i, 4)
　　　　If myDic.Exists(myStr) Then
　　　　　　myW2(i, 1) = myDic(myStr)
　　　　Else
　　　　　　myW2(i, 1) = "無"
　　　　End If
　　Next i
　　Sheets("集計").Range("H1").Resize(uw, 1).ClearContents
　　Sheets("集計").Range("H1").Resize(uw, 1).Value = myW2
End Sub

お礼

ありがとうございます。
1秒かかりませんでした。
正直このマクロはたくさん処理をしているので
ここで２０秒かかると、ちょっと痛いのです。
おかげで助かりました。
本当にありがとうございます。

コメントを入れてみました。
合っていますか。（言葉は不適切かもしれません）
対象列が1列の場合はこの間、別スレッドで
教えていただいたので、自分で書きかえれるように
なりました。
ですが複数列連結はまったくわからないです。
このコメントがあっていれば、セル連結での照合時も
対象列が変わったくらいなら、自分で書き換えが出来ます。
あとコメント入れたくてもわからないのが
ReDim myW2(1 To uw, 1 To 1) As String
For i = 1 To uv
myW2(i, 1) = myDic(myStr)
の部分です。どういうコメントが適切でしょうか？

Sub 番号変換03()
'2010年12月13日
'Dictionaryオブジェクト
Dim myV, myV2, myW, myW2
Dim i As Long, uw As Long, uv As Long
Dim myStr As String
Dim myDic As Object

'検索されるシート
With ThisWorkbook.Sheets("新番号")
'検索されるシートの検索する列を配列に取り込む（A列2行目からE列まで）
myV = .Range("A2", .Cells(Rows.Count, "E").End(xlUp)).Value
End With
With Sheets("集計")
'検索値のあるシートの検索値の有る列を配列に取り込む（I列1行目からL列まで）
myW = .Range("I1", .Cells(Rows.Count, "L").End(xlUp)).Value
End With
uv = UBound(myV)
uw = UBound(myW)
ReDim myW2(1 To uw, 1 To 1) As String
Set myDic = CreateObject("Scripting.Dictionary")
For i = 1 To uv
'検索される値の指定（A列を1として1,2,3列目を検索される値とする（A,B,C列））と
'ヒット時に返す値を指定　5=E列
myDic(myV(i, 1) & "!" & myV(i, 2) & "!" & myV(i, 3)) = myV(i, 5)
Next i
For i = 1 To uw
'検索値とする列を指定(I列を1として1,3,4列目を検索値とする（I,K,L列））
myStr = myW(i, 1) & "!" & myW(i, 3) & "!" & myW(i, 4)
If myDic.Exists(myStr) Then
myW2(i, 1) = myDic(myStr)
Else
'ヒットしない場合
myW2(i, 1) = "無"
End If
Next i
'転記するシートと列を指定する　H列1行目
Sheets("集計").Range("H1").Resize(uw, 1).ClearContents
Sheets("集計").Range("H1").Resize(uw, 1).Value = myW2
End Sub

補足

ありがとうございます。

merlionXXさんを混乱させた、スレッドの質問内容の件です。

BOOK1にマクロがあり、それを起動すると
ファイル選択画面になり、CSVファイルを選択すると
BOOK2が開きインポートされてシート名が集計になる。
CSVファイルが閉じられる。
でBOOK2のシート集計が編集されていく。
BOOK1には、BOOK2の編集時に使用するマスター用の
シートがあります。
・従業員マスタ
・新番号
・最終行
これはmerlionXXさんに作ってもらった物です。
（４３回も回答してもらいました。）

なぜこれを冒頭に書いたかというと、
Dictionaryオブジェクトの応用は、ついこの間もアドバイス
していただきまして、列がちょっと変わったくらいなら
自分で書きかえれるようになったのですが、
それは同じBOOK内に対象シートが双方ある場合です。
対象のシートがBOOK1とBOOK2に分かれている場合は
分からなかったので
それを説明したくて冒頭に記載しました。m(__)m

この教えていただいた記述Sub TEST03を
まっさらなBOOK3に挿入しました。
でそのBOOK3に
・シート集計
・シート新番号
を作成し、同じデータ配列でデータを作成して
Sub TEST03を走らせたら、思ったとうりに動作しました。

これは、当たり前　ですか？
それとも偶然でしょうか？

当たり前なら、冒頭で、BOOK1だのBOOK2だのの
説明は不要だったになるのですが。
その辺も？？？？なんです。

それから、Dictionaryオブジェクトが分かりません。
VLOOKUPは1行ごとに処理をする記述の場合、
ＶＢＥでＦ８キーを押しながら動きを確認すると、
2回押すごとに1行ごとに返ってきた値が転記されていきます。
2万行有れば４万回押す事になります。
DictionaryオブジェクトもＦ８キーで見ると
同じ記述の部分をいったりきたりで
おそらく行数文Ｆ８キーを押さないと次に進まない？
なのにVLOOKUPだと凄く時間がかかって
Dictionaryオブジェクトが速いのか分かりません。
Ｆ８キーでの動作確認では大差ないです。
配列に取り込むのが速いのは
エクセルを手操作でも分かります。
5列60,000行でもコピー＆ペースト等は秒速です。
配列に取り込んだ後は1値ごとにぶつけていく（違うのかな）
ので処理数が増えるので遅くなるはずなのに
なぜ秒速で処理されるのでしょうか？

Dictionaryオブジェクトがわかっていないのに
Dictionaryオブジェクトで書いてくださいと要求して
大変申し訳ありません。

回答No.6

merlionXX

gx9wxちゃんこんにちは。
こども電話相談室のmerlionXXです。

> Set wb = ActiveWorkbook
開かれてアクティブになったBOOKをwbとしてます。

> wb.Sheets(1).Cells.Copy ThisWorkbook.Sheets("対象データ").Cells
wbの一番左側のシートの全セルをコピーし、マクロが書いてあるBOOKのSheets("対象データ")に貼ってます。
Sheets(1)とは、一番左にあるシートのことです。
そう指定してますのでこのシートはアクティブであろうがなかろうが、名前が何であろうが、コピーされます。

> wb.Close (False)
wbを閉じました。

これで、他に開いてるBOOKがなければマクロが書いてあるBOOKがアクティブになったはずです。
そのときマクロが書いてあるBOOKのどのシートがアクティブかわからないので、次に作業をする（？）Sheets("対象データ")を明確にアクティブにするためにSelectしてるんだと思います。

> 選択したファイルのアクティブシートを転記したい。
そういうご指定ならSheets(1)とは書かず、
wb.ActiveSheet.Cells.Copy ThisWorkbook.Sheets("対象データ").Cells
あるいは単に
Cells.Copy ThisWorkbook.Sheets("対象データ").Cells
になると思います。

お礼

取り込み時のシートの指定方法ありがとうございました。
取り込んで新しいBOOKが出来る時、
マクロが書いてあるBOOKの他のシートに取り込む場合
ともに理解できました。
どうもありがとうございました。

回答No.5

merlionXX

おはようございます。
毎度二日酔いのmerlionXXです。
昨夜は、もんじゃ屋でした。

> 記述のどこをもってでBOOK2のシート　集計　が
> アクティブなのか分かりません。

> Set wBook = Workbooks.Add
ここで新しいBOOK（が作成され、それをwBookとしています。これが、あなたが言うBOOK2ですね？
新しいBOOKを作成すると必ずその新たなBOOKがアクティブになります。

> Set wSheet = wBook.Worksheets(1)
そのアクティブなBOOKの最初のSheet(当然アクティブになっているはず)をwSheetとし、

> wSheet.Name = "集計"
その名前を"集計"としているのですから、途中でアクティブでなくなるようなコードが無い限りSheets("集計")がアクティブです。
Callで呼ばれる、Sub　編集（）は省略部分はわかりませんが、かかれているコードは、アクティブなBOOKの Sheets("集計")に対する操作です。

> wBook.SaveAs Filename:=dPath & "\実績" & Year(Now) & Format(Month(Now), "00") & Format(Day(Now), "00") & ".xls", _
> FileFormat:=XlFileFormat.xlWorkbookNormal
これで作成されたBOOK（wBook）が名前を付けて保存されました。（アクティブです）

> wBook.Close
wBookを閉じました。（当然アクティブではなくなります。）
そのとき開いているのがマクロを書いたBOOK、（これがあなたが言うBOOK1ですね？）しかなければ、当然そのBOOK（マクロで言えばThisWorkBook）がアクティブになります。

なんだか、こども電話相談室の回答者をやってるような気になってきました。
φ(^o^:)

お礼

凄く丁寧にありがとうございます。
いつもここまで丁寧に教えてくださいますので
つい甘えてしまいます。
アクティブの件でふと疑問が。
別スレッドで教えていただいた以下の記述。

Sub データ取得()
'2010年12月8日
'エクセルの「ファイルを開く」画面を出してファイルを選択させる
'そのファイルを選択してウィンドー内の開くをクリックすると
'そのファイルのデータがシート「対象データ」に転記され
'その選択ファイルは閉じられる。
'（１）シート「手順」はコマンドボタンが２個で
'開始ボタンには「Subデータ取得」、
’終了ボタンには「Sub　上書保存」を登録してある。
'（２）シート「対象データ」は
’選択したエクセルファイルが転記されるシート
'（３）シート「マスター」は
’区分番号のマスターデータがあるシート
’これを使用してシート「対象データ」を編集する
MsgBox "データを取得するエクセルファイルを選択する画面を開きます"
Dim wb As Workbook
If Application.Dialogs(xlDialogOpen).Show = False Then
MsgBox "きゃんせる"
Exit Sub
Else
Set wb = ActiveWorkbook
wb.Sheets(1).Cells.Copy ThisWorkbook.Sheets("対象データ").Cells
wb.Close (False)
Set wb = Nothing
Sheets("対象データ").Select
'dictionaryオブジェクトでシート「マスター」から区分番号を取得します
Call 区分番号取得
Range("AE1") = "区分番号"
MsgBox "区分番号の取得が完了しました"
End If
Sheets("手順").Select
MsgBox "画面の【終了】をクリックしてください"
End Sub
-----
この場合は、Sheets("対象データ").Selectがあるので
これがアクティブなのは分かりました。

上記マクロの処理中に選択したエクセルファイルからの
転記ですが
選択したエクセルファイルに複数のシートが有る場合は
どのシートを選択するのでしょうか？
選択したファイルのアクティブシートが転記される
という考えは間違っていますでしょうか？
私は選択したファイルを開いた時に選択されてるシートが
アクティブシートでそれが転記される
と思っていましたが違うのでしょうか？

例えば上記マクロを走らせ、
エクセルファイル「売上」を選択します。
そのBOOKには
左から
シート９月
シート１０月
シート１１月
と３個のシートがあります。
この場合、シート９月がシート「対象データ」に転記されました。

エクセルファイル「売上」をマクロは使用せずに単独で開き、
シート１１月を選択して
そのシートのセルC100にカーソルを置いて
上書保存しました。
このエクセルファイル「売上」を再度単独で開くと
シート１１月のC100にカーソルが置かれた状態で開きます。
私の中では
「このエクセルファイル「売上」のアクティブシートは
シート11月だ」
となっています。

この状態で、
上記マクロの処理中にファイル「売上」を選択しても、
シート「対象データ」に転記されるのは
やはりシート９月でした。
これがまた分かりません。
webでいろいろ調べましたが
見つかりませんでした。m(__)m

補足

今回の回答の補足。

別スレッドで教えていただいた記述の
私がこうしたいと言った条件は

・データ配列等は同じだが
・選択するエクセルファイル名は都度相違
・そのファイルにはシートがいくつあるか不明
・またそのシート名は都度違う

選択したファイルのアクティブシートを転記したい。

だったと思います。多分．．．．．m(__)m

回答No.4

merlionXX

> まっさらなBOOK3に挿入しました。
略
> Sub TEST03を走らせたら、思ったとうりに動作しました。
> これは、当たり前　ですか？

そのBOOK３にマクロを書き、BOOK３のシートに操作するならあたりまえです。
めんどうなのは、マクロを書いた以外の他のBOOKに対する操作のときです。
マクロを書いたBOOKであれば、Thisworkbookと特定出来ますが、他のBOOKは名前がわからないと特定できません。
しかし、名前がわからなくとも、そのBOOKがアクティブになっていれば、そのBOOKの名前のわかっているシートには操作できます。
シート名がわかっていてもそのBOOKがアクティブでなければエラーになります。
だから「アクティブという前提」とことわったのです。
そういうことは回答者はわかりませんから、ちがうBOOKに操作したいならそのBOOKがどんな状態にあるのか書かなくてはいけません。

> なのにVLOOKUPだと凄く時間がかかって
> Dictionaryオブジェクトが速いのか分かりません。

Dictionaryは名の通り、辞書です。
辞書にA,B,C列の連結値を単語（Key）登録し、辞書の説明に当たる部分(Item)にE列の値を登録しました。
これで1件ずつ見る必要がなく、単語が登録してあれば一発でItemが取得できます。（だから重複は不可）
1件ずつ、あるかどうか総当りで見るのと、ピンポイントで一つの単語だけ辞書を引くのでは速度に大きな違いが出ます。

> の部分です。どういうコメントが適切でしょうか？

> ReDim myW2(1 To uw, 1 To 1) As String
2次元配列myW2の範囲、1次元（行）方向を1からuw、2次元（列）方向を1から1に用意（変数uwはすでに代入されています）

> For i = 1 To uv
変数iは1からuvまで（変数uvはすでに代入されています）

> myW2(i, 1) = myDic(myStr)
2次元配列myW2のi行1列＝DictionaryでmyStrに該当する値（変数myStrはすでに代入されています）

コメントはおおむね正しいと思いますが、気になったのは日本語です。
「検索値」と「検索される値」という言葉を逆に使っていませんか？
今回の場合、重複のないSheets("新番号")のA,B,C列の連結値が検索値で、重複データのあるSheets("集計")のI,K,L列の連結値が検索される値になります。
ワークシート関数でもたとえば、
=VLOOKUP(検索値、範囲、列番号、検索方法）ですよね。検索値で範囲を調べるのです。つまり範囲にあたるのは検索される方です。

なお、余談ですが先週は昼のお座敷が終わって家に帰ってから、酔っ払いが回答したんですよ。
他の回答者の方がいらっしゃったので触れませんでしたが。
これから年末年始、もうひっきりなしです。(*^∇^)ノロ

お礼

Dictionaryオブジェクトの説明ありがとうございました。
参考書にも、WEBサイトにもここまで噛み砕いた説明は
ありませんでした。

コメントの件もありがとうございます。

＞なお、余談ですが先週は昼のお座敷が終わって家に帰ってから、
＞酔っ払いが回答したんですよ。

あの時、なぜ回答が来たのかとその理由がなかったので
不思議でしたが、わかりました。

今日は金曜日ですね。
また行かれるのですね。
忘年会．．．．ここ２年１度も機会がないです。(ToT)/~~~

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

補足

いつもお世話になりありがとうございます。
「BOOK2はアクティブですか？」
という件について。

VBEでF8キーで送っていったら、
Call編集に入った時点でもBOOK2のシート編集が
選択されてそのシートに編集作業が行われていたので
「アクティブです。」と回答しました。

下に書きました記述がBOOK1に書かれていて、
それを起動しBOOK2が登場するのですが、
記述のどこをもってでBOOK2のシート　集計　が
アクティブなのか分かりません。

途中でCall　編集にてプロシージャーが呼ばれます。
そのSUb　編集　でBOOK2のシート集計の記述によって
なるのかもしれないので
Sub　編集　の冒頭の記述も書いておきます。m(__)m

記述の中に
Worksheets("Sheet1").Selectとかあれば分かるのですが．．．
たまにWorksheets("Sheet1").Selectとか入れると
「まったく無意味です不要です。」というアドバイスを
受ける場合もありました。
その辺がまだよく分からないのです。
----------
Sub CSV取得()
Dim fName
Dim wBook As Workbook
Dim wSheet As Worksheet
Dim fso As Object
Dim dPath As String
fName = Application.GetOpenFilename(FileFilter:="CSVファイル(*.csv),*.csv" _
, FilterIndex:=1, Title:="CSVファイルを選択してください。", MultiSelect:=False)
If fName = False Then
MsgBox "きゃんせる"
End
End If
Set fso = CreateObject("Scripting.FileSystemObject")
dPath = fso.GetParentFolderName(fName)
Set wBook = Workbooks.Add
Set wSheet = wBook.Worksheets(1)
Application.ScreenUpdating = False '画面更新停止
wSheet.Name = "集計"
With wSheet.QueryTables.Add(Connection:="TEXT;" & fName, Destination:=wSheet.Range("A1"))
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierNone
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = False
.TextFileCommaDelimiter = True
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 5, 1, 2, 2, 2, 2, 2, 1)
.Refresh BackgroundQuery:=False
End With
Application.ScreenUpdating = True '画面更新停止解除

Call 編集

wBook.SaveAs Filename:=dPath & "\実績" & Year(Now) & Format(Month(Now), "00") & Format(Day(Now), "00") & ".xls", _
FileFormat:=XlFileFormat.xlWorkbookNormal
wBook.Close
Application.Calculation = xlAutomatic
Application.ScreenUpdating = True
MsgBox "編集終了"
Sheets("手順").Select
End Sub
----
'Callで呼ばれるプロシージャー
Sub　編集（）
Dim myAr As Variant
Dim i As Long
With Sheets("集計")
With .Range(.Range("A1:L1"), .Range("A1:L1").End(xlDown))
myAr = .Value
For i = LBound(myAr, 1) To UBound(myAr, 1)
Select Case myAr(i, 1) '
以下省略

回答No.2

merlionXX

そうですか、重複があるのでしたらDictionaryオブジェクトでの高速化は無理ですね。
（前回も、「データに重複がないのならDictionaryオブジェクトを使わない手はないですね」と書いたと思います。）
ではこれではいかがでしょうか？

Sub TEST02()
　　Dim t As Single
　　t = Timer
　　Dim myV, myV2, myW, myW2、myX
　　Dim i As Long, n As Long, uw As Long, uv As Long
　　Dim buf As Boolean
　　With ThisWorkbook.Sheets("新番号")
　　　　myV = .Range("A2", .Cells(Rows.Count, "E").End(xlUp)).Value
　　End With
　　With Sheets("集計")
　　　　myW = .Range("I1", .Cells(Rows.Count, "L").End(xlUp)).Value
　　End With
　　uv = UBound(myV)
　　uw = UBound(myW)
　　ReDim myV2(1 To uv, 1 To 1) As String
　　ReDim myW2(1 To uw, 1 To 1) As String
　　ReDim myX(1 To uw, 1 To 1) As String
　　For i = 1 To uv
　　　　myV2(i, 1) = (myV(i, 1) & "!" & myV(i, 2) & "!" & myV(i, 3))
　　Next i
　　For i = 1 To uw
　　　　myW2(i, 1) = myW(i, 1) & "!" & myW(i, 3) & "!" & myW(i, 4)
　　Next i
　　For i = 1 To uv
　　　　For n = 1 To uw
　　　　　　If myV2(i, 1) = myW2(n, 1) Then
　　　　　　　　myX(n, 1) = myV(i, 5)
　　　　　　　　buf = True
　　　　　　End If
　　　　Next n
　　Next i
　　For n = 1 To uw
　　　　If myX(n, 1) = Empty Then
　　　　　　myX(n, 1) = "無"
　　　　End If
　　Next n
　　Sheets("集計").Range("H1").Resize(uw, 1).ClearContents
　　Sheets("集計").Range("H1").Resize(uw, 1).Value = myX
　　Debug.Print Timer - t
End Sub

お礼

ありがとうございます。
BOOK1シート集計が約７，５００行
BOOK2シート新番号が約９，７００行で
２０秒くらいです。
画面下の表示、再計算　０％→１５％→３０％．．．．
も出なくなりました。
ありがとうございました。

回答No.1

merlionXX

正直、非常にわかりにくい質問です。
一連のマクロの流れのなかの一つのプロシージャの話なんですね。

> BOOK1で（Sub　CSV取得)を動作させると

マクロがかかれているのがBOOK1なんですね？

> BOOK2のシート集計の編集作業を行う

このとき、BOOK2がアクティブになっているのかないのか不明。
これまでのgx9wxさんのコードを見ると、作業対象のBOOKはアクティブにしていたようなのでアクティブという前提にします。
というか、アクティブでなかったらBOOK2の名前がわからないと書けない。

> dictionaryオブジェクトを使用

と、指定するからには、3列結合データには絶対重複はないという前提でいいんですね。
また、対象の3列に空白はないという前提で書いてます。

Sub TEST01()
　　Dim myV, myV2, myW, myW2
　　Dim i As Long, uw As Long, uv As Long
　　Dim myDic As Object
　　With ThisWorkbook.Sheets("新番号")
　　　　myV = .Range("A2", .Cells(Rows.Count, "E").End(xlUp)).Value
　　End With
　　With Sheets("集計")
　　　　myW = .Range("I1", .Cells(Rows.Count, "L").End(xlUp)).Value
　　End With
　　uv = UBound(myV)
　　uw = UBound(myW)
　　ReDim myV2(1 To uv, 1 To 1) As String
　　ReDim myW2(1 To uw, 1 To 1) As String
　　Set myDic = CreateObject("Scripting.Dictionary")
　　For i = 1 To uv
　　　　myV2(i, 1) = (myV(i, 1) & "!" & myV(i, 2) & "!" & myV(i, 3))
　　Next i　　
　　For i = 1 To uw
　　　　myDic(myW(i, 1) & "!" & myW(i, 3) & "!" & myW(i, 4)) = i
　　　　myW2(i, 1) = "無"
　　Next i
　　For i = 1 To uv
　　　　If myDic.Exists(myV2(i, 1)) Then
　　　　　　myW2(myDic(myV2(i, 1)), 1) = myV(i, 5)
　　　　End If
　　Next i
　　Sheets("集計").Range("H1").Resize(uw, 1).ClearContents
　　Sheets("集計").Range("H1").Resize(uw, 1).Value = myW2
End Sub

お礼

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

申し訳ありません。
補足に書きましたがBOOK2のシート集計に重複行が
ある為、例えば１０行重複行があると、
1行はBOOK1のシート新番号のＥ列の値が返ってきますが
残りの9行は無と転記されます。

VLOOKUPでしかだめだと思い
もう少し高速のVLOOKUPの以下の記述ですが

　BOOK2のシート集計のI,K,L列の順で連結した値を検索値として
　BOOK1のシート新番号のA,B,C列の順で連結した値を検索し
　ヒットしたらBOOK1のシート新番号の該当行のE列
　　（セル書式標準半角英数字３ケタ）を
　BOOK2のシート集計のH列に転記する。
　ヒットしない場合は　無　と転記する。
　BOOK2のシート集計はA列からO列でデータは1行目から。
　BOKK1のシート新番号はA列からE列でデータは2行目から。

において3列の連結がわからないのと、
検索されるのがBOOK1で検索値と転記先がBOOK2に
分かれているのでそこが分からず
全て　無　と転記されお手上げです。（泣）

----

Sub 番号変換VL()
'2010 年12月13日
'式は貼付けずに1行ごとの処理だが式貼付より速い。
'シート集計のI列を検索値として
'シート新番号のＡ列を検索しヒットしたら
'シート新番号の該当行のＥ列をシート集計のＨ列に転記
'ヒットしない場合は　無　と転記

'検索する対象値があるシート選択
Sheets("集計").Select
'そのシートの検索開始の行数を選択2行目。
Line = 1
'そのシートの検索値の列指定9=I列。セルI1の値が検索したい値。
'その値がなくなったら検索を終了させる.Value = ""を追加。
Do Until Cells(Line, 9).Value = ""
'エラーとなっても次に進む
On Error Resume Next
'検索結果を記入する列を指定。Line8=H列（※１）
'検索する値があるシートとその列を指定
'VLookup(Cells(Line, 1)の部分。1=A列
'検索されるシートと検索範囲を指定
'Worksheets("新番号").Range("A2:E60000")
'→セルA2からセルE60000まで
'検索されたらその行のどの列の値を結果とするのか指定　5=E列
'検索方法指定0=FALSE完全一致。

Cells(Line, 8).Value = Application.WorksheetFunction.VLookup(Cells(Line, 1).Value, Worksheets("新番号").Range("A1:E60000"), 5, 0)

'VLOOKUP関数が終了又はエラーが発生したら止まる
On Error GoTo 0
'検索されなかったときの処理。上記（※１）の部分Line8=H列に値がない
If Cells(Line, 8).Value = "" Then
'Line6=F列にLine6=E列の値を代入
Cells(Line, 8).Value = "無"
End If
'2行目から開始なので次の行の値を検索値とする
Line = Line + 1
'検索する値がなくなるまで繰返す
Loop
MsgBox "終了"
End Sub

補足

>マクロがかかれているのがBOOK1なんですね？
はい。そうです。

>アクティブという前提にします。
BOOK2のシート集計がアクティブです。

>指定するからには、3列結合データには絶対重複はないという
>前提でいいんですね。

勉強不足でした。m(__)m
応用したいと説明して載せた記述は別質問で教えていただき、
利用していました。
でそれを記載した内容に書き換えて別のBOOKでも使っていました。
今回はVLOOKUPが処理が遅いので2つのBOOKで速度も速く
成功していたのでまた応用しようと思いました。
過去2回のBOOKでの使用と今回では大きな違いが有りました。
過去2回では
いずれも、シート1、シート２で各シート内で重複データは
存在しません。
ですが今回の場合は片側のシートはシート内で
重複しています。
検索値が有る方のシート１（BOOK2のシート集計）には
重複データだらけです。
で検索されるシート２（BOOK1のシート新番号）には
重複データがありません。
シート集計のデータは入出庫記録ですから
同じデータが何回も何回も出てきます。
シート新番号は基幹システムのマスターなので重複は有りません。
（Ａ列だけでは重複になるがＡ，Ｂ，Ｃと連結で無くなる）

例：I,K,L列
シート集計
XXXX,1111,2222
XXXX,1111,3333
XXXX,1111,2222
XXXX,1111,3333
XXXX,2222,3333
XXXX,1111,3333

シート新番号　A,B,C列→E列
XXXX,1111,2222→B99
XXXX,1111,3333→B99
XXXX,2222,3333→C77
↓
処理後のシート集計
XXXX,1111,2222→H列にB99
XXXX,1111,3333→H列にB99
XXXX,1111,2222→H列にB99
XXXX,1111,3333→H列にB99
XXXX,2222,3333→H列にC77
XXXX,1111,3333→H列にB99

今回の場合はdictionaryオブジェクトでは駄目ですよね。
現在のVLOOKUPの式をコピーして結果を値貼付する
方法以外に
1行ごとにVLOOKUPする記述も作ってあり、
そちらは同じ行でも２分以内で終了するので、
1行ごとVLOOKUP処理LOOP文で対応してみます。
何でも応用すればいいのではないのですね。
dictionaryオブジェクトが理解していないのに
応用しようと考えたのがあさはかでした。
お手数かけました。
どうもありがとうございました。