ExcelVBA マクロの高速化について

Question

２つのEXCELファイルがあります。

・TEST1.xlsx
・TEST2.xlsx

これらのEXCELファイルのセルの値を比較し合致した場合、
TEST2.xlsxの値をTEST1.xlsxの値に設定しています。
ただし行数が多いせいか処理に時間がかかってしまいます。

配列で保持し、最後に一気に張り付ける方法も考えたんですが、
貼り付けるTEST1.xlsxのフォーマットに癖があるため難しい状況です。
良い方法があればご教示お願い致します。


For i = 1 To 5000
 For j = 1 To 10000
  If Workbooks("TEST1.xlsx").WorkSheets("Sheet1").Range("A" & i).Value =
     Workbooks("TEST2.xlsx").WorkSheets("Sheet1").Range("A" & j) Then


     Workbooks("TEST1.xlsx").WorkSheets("Sheet1").Range("A" & i).Value = 
     Workbooks("TEST2.xlsx").WorkSheets("Sheet1").Range("A" & j).Value 
Exit For
End If
Next
Next

WindFaller · Accepted Answer

#6の回答者ですが、

>行数は固定ではありませんが、実際のソース上は行数を取得するように記載しております。
？分からないです。
>現状はキーが1つ、セットする値も1つですが、

というのは、もしかしたら、二重のループにして、同じ値を、その全部から探すつもりだったのですね。それはアルゴリズムを知らないとできません。しかし、VBAでは、そういうアルゴリズムの方法は書き方はしません。だから、言葉で説明していただいたほうがよかったでしょうね。他の方が気づいているようですから、私が間が抜けているのか、察しが悪いのか、#6のコードは、バカがつくほどみっともないです。本日の締めは、綺麗に終わりたいものです。これでうまくいくとは限らないものの、やっとスタートラインについたようです。

以下は、配列づくしですが、それを１次元にしています。

'//
Sub TestMacro2()
　　Dim Sh1 As Worksheet
　　Dim Sh2 As Worksheet
　　Dim rw As Long, k As Long, i As Long
　　Dim ar1, ar2, ar3, ar4
　　Dim buf
　　
　　Set Sh1 = Workbooks("TEST1.xlsx").Worksheets("Sheet1")
　　Set Sh2 = Workbooks("TEST2.xlsx").Worksheets("Sheet1")
　　With Sh1
　　　　buf = .Range("A1", .Cells(Rows.Count, "A").End(xlUp))
　　　　rw = UBound(buf)
　　　　ar1 = Application.Transpose(buf)
　　　　buf = .Range("B1").Resize(rw).Value
　　　　ar3 = Application.Transpose(buf)
　　　　ReDim ar4(LBound(ar3) To UBound(ar3))
　　End With
　　With Sh2
　　　　buf = .Range("A1").Resize(rw).Value
　　　　ar2 = Application.Transpose(buf)
　　End With
　　For i = LBound(ar1) To UBound(ar1)
　　　　On Error Resume Next
　　　　k = 0
　　　　k = Application.Match(ar1(i), ar2, False)
　　　　If k > 0 Then
　　　　　　ar4(k) = ar3(i)
　　　　End If
　　　　On Error GoTo 0
　　Next i
　　Sh2.Range("B1").Resize(rw).Value = Application.Transpose(ar4)
End Sub
'///

nokirag · Answer

このコード実はTEST1.xlsxが一切変更されないので、
処理を行わないことがもっとも高速化につながるかと思います。

30246kiku · Answer

私も Dictionary を使うのに１票

Excel だけじゃないと思いますが、
何かをまとめたい/集計したい等･･･ Dictionary は便利だと思います

> For i = 1 To 5000
> For j = 1 To 10000

とあった時、片方の For を削れば速くはなります
また、10000 → 5000 にすればチョットは速くなる？
でも、両方とも、やりたいことはできないと思います･･･
j 側は参照用途なら、j 側の内容を Dictionary に覚えます

For i = 1 To 5000
　　覚えた Dictionary に xx(i) があるか･･･

すると速くなったと思います
また、セル内容の入手/設定の回数を減らすことでも速くできたと思います

以下、未実行でおかしなところがあるかもしれませんが･･･

処理）TEST1.xlsx /TEST2.xlsx は既にオープン済みということで

・TEST2.xlsx のシート Sheet1 の A, B 列を変数に一気に入手
・A 列の内容をキーに Dictionary に情報を覚えます

　・Samp1：覚える値は、B 列の内容
>　　　　If (vA(i, 1) <> "") Then
>　　　　　　If (Not dic.Exists(vA(i, 1))) Then
>　　　　　　　　dic(vA(i, 1)) = vA(i, 2)
>　　　　　　End If
>　　　　End If
　　For で 1 ～　して見つかったらという処理だったので
　　A 列の値が重複していたら値を覚えなおすことはしないように･･･

　・Samp2：覚える値は、行番号
>　　For i = 1 To UBound(vA)
>　　　　If (vA(i, 1) <> "") Then
>　　　　　　If (Not dic.Exists(vA(i, 1))) Then
>　　　　　　　　dic(vA(i, 1)) = i
>　　　　　　End If
>　　　　End If
>　　Next

・TEST1.xlsx のシート Sheet1 の A, B 列を変数に一気に入手
・A 列の内容で Dictionary 情報を参照します
　・Samp1：覚えていたら、覚えていた内容を１列目に設定
>　　　　　　　　If (dic.Exists(vA(i, 1))) Then
>　　　　　　　　　　vA(i, 1) = dic(vA(i, 1))
>　　　　　　　　Else
>　　　　　　　　　　vA(i, 1) = vA(i, 2)
>　　　　　　　　End If
　　　※　覚えていなかったら、B 列の内容はいじらないので

　・Samp2：覚えていたら、行番号 > 0 が得られるので
　　　　　　　それを使って１列目に設定
>　　　　　　　　j = dic(vB(i, 1))
>　　　　　　　　If (j > 0) Then
>　　　　　　　　　　vB(i, 1) = vA(j, 2)

・突き合わせ処理が終わったら、変数の書き出し
>　　　　　　.Offset(, 1).Value = vA

この時の Offset 基準は

>　　With Workbooks("TEST1.xlsx").Worksheets("Sheet1")
>　　　　With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))

なので、B 列に一気に設定することに
変数は２列分になってますが、書き出し先は1列分なので、
変数の1列目だけが書き出されることに･･･
なので、B 列に変更なかった時、１列目に値を移してました
なお、書き出しは１回だけなので、
Application.ScreenUpdating = False / True 制御は要らないものに

Public Sub Samp1()
　　Dim dic As Object
　　Dim vA As Variant
　　Dim i As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　With Workbooks("TEST2.xlsx").Worksheets("Sheet1")
　　　　With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
　　　　　　vA = .Resize(, 2).Value
　　　　End With
　　End With
　　For i = 1 To UBound(vA)
　　　　If (vA(i, 1) <> "") Then
　　　　　　If (Not dic.Exists(vA(i, 1))) Then
　　　　　　　　dic(vA(i, 1)) = vA(i, 2)
　　　　　　End If
　　　　End If
　　Next

　　With Workbooks("TEST1.xlsx").Worksheets("Sheet1")
　　　　With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
　　　　　　vA = .Resize(, 2).Value
　　　　　　For i = 1 To UBound(vA)
　　　　　　　　If (dic.Exists(vA(i, 1))) Then
　　　　　　　　　　vA(i, 1) = dic(vA(i, 1))
　　　　　　　　Else
　　　　　　　　　　vA(i, 1) = vA(i, 2)
　　　　　　　　End If
　　　　　　Next
　　　　　　.Offset(, 1).Value = vA
　　　　End With
　　End With

　　Set dic = Nothing
End Sub

Public Sub Samp2()
　　Dim dic As Object
　　Dim vA As Variant, vB As Variant
　　Dim i As Long, j As Long

　　Set dic = CreateObject("Scripting.Dictionary")

　　With Workbooks("TEST2.xlsx").Worksheets("Sheet1")
　　　　With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
　　　　　　vA = .Resize(, 2).Value
　　　　End With
　　End With
　　For i = 1 To UBound(vA)
　　　　If (vA(i, 1) <> "") Then
　　　　　　If (Not dic.Exists(vA(i, 1))) Then
　　　　　　　　dic(vA(i, 1)) = i
　　　　　　End If
　　　　End If
　　Next

　　With Workbooks("TEST1.xlsx").Worksheets("Sheet1")
　　　　With .Range("A1", .Cells(.Rows.Count, "A").End(xlUp))
　　　　　　vB = .Resize(, 2).Value
　　　　　　For i = 1 To UBound(vB)
　　　　　　　　j = dic(vB(i, 1))
　　　　　　　　If (j > 0) Then
　　　　　　　　　　vB(i, 1) = vA(j, 2)
　　　　　　　　Else
　　　　　　　　　　vB(i, 1) = vB(i, 2)
　　　　　　　　End If
　　　　　　Next
　　　　　　.Offset(, 1).Value = vB
　　　　End With
　　End With

　　Set dic = Nothing
End Sub

余談）

以下QAで、ある回答者さんが高速化についてのブログを紹介されてます
http://detail.chiebukuro.yahoo.co.jp/qa/question …

Dictionary は、値部分をどのように使うかによって色々便利かな
使えるようにしておくと良いかも？

Dictionary と変数の連携例？
http://detail.chiebukuro.yahoo.co.jp/qa/question …

Dictionary の重複排除を利用した例？
http://detail.chiebukuro.yahoo.co.jp/qa/question …

値を配列で持って集計していく例？
http://oshiete.goo.ne.jp/qa/9136052

値部分にさらに Dictionary を組み込んだ２段構成の例？
http://oshiete.goo.ne.jp/qa/9131595.html

また、値部分にワークシートを設定したり、３・４段構成にしてみたり･･･
Dictionary は便利だと思います（結構速いし･･･）

WindFaller · Answer

#2の回答者です。ちょっと話の流れが変わってきてしまっているように思うのですが、どうも、もう一つ具体性がないので、私としては話は中途半端な解釈です。 #3さんのところで意味が分かりました。 >EXCELファイルのセルの値を比較し合致した場合要件としては、「２つのシートのA列を比較して、同じアドレスにある値が一致すれば、Test1側のB列の値をTest2 側のB列に貼り付ける」というものですね。「書式が必要なら、範囲を書式コピーすればよいです」どうりで話が見えないはずです。でも、また、ふつう高速化するなら、時々、ここに現れる、某氏が得意なワザで、二分探索とかなるのですが、私の得意技でもありませんし、その必要もないように思います。データ数は5,000個なのでしょうか。5,000や10,000個程度のデータなら、高速化する必要はないと思うのですが、まだ他に条件が出てきそうな気がします。 >空白行が複数あるため空白行を意識しなければならないため難しい状況当面ですが、配列のみで処理してみました。空白があろうがなかろうが、あまり関係ないはずです。空白値も値ですから。ただし、エラー値は、比較できませんから、エラートラップが必要になるでしょう。コードとしては、あまり格好が良くありませんが、とりあえず、お話のままに作ってみました。(ar4の1次元にする意味は、何もありません。気まぐれです) '// Sub TransferMacro() 　　Dim Sh1 As Worksheet 　　Dim Sh2 As Worksheet 　　Dim rw As Long 　　Dim i As Long 　　Dim ar1, ar2, ar3, ar4 　　　　Set Sh1 = Workbooks("TEST1.xlsx").Worksheets("Sheet1") 　　Set Sh2 = Workbooks("TEST2.xlsx").Worksheets("Sheet1") 　　With Sh1 　　　　ar1 = .Range("A1", .Cells(Rows.Count, "A").End(xlUp)) 　　　　rw = UBound(ar1) 　　End With 　　ar2 = Sh2.Range("A1").Resize(rw).Value 　　ar3 = Sh1.Range("B1").Resize(rw).Value 　　ar4 = Application.Transpose(ar3) 　　　　For i = LBound(ar4) To UBound(ar4) 　　　　If ar1(i, 1) <> ar2(i, 1) Then 　　　　　　ar4(i) = Empty 　　　　End If 　　Next i 　　Sh2.Range("B1").Resize(rw).Value = Application.Transpose(ar4) End Sub '/// エラー値が入る場合は、ループの中をこのようにすればよいです。　　 On Error Resume Next 　　　　If ar1(i, 1) <> ar2(i, 1) Then 　　　　　　ar4(i) = Empty 　　　　End If 　　　　On Error GoTo 0

googoo900 · Answer

for nextの総当たりチェックは使う機会が多いですが、遅いのが欠点です。データが多い場合は使いものになりません。
高速化するために、book2のデータをbook1に一時的にコピーして、MATCH関数を使って照合しています。
MATCH関数はワークシート上で使っています。マクロで使うとエラー処理が必要と思います。
コピーしたデータは消すようにしています。

Sub Macro2()
Dim i As Integer
'book2の内容をコピー
Windows("Book2.xlsx").Activate '
Worksheets("Sheet1").Activate '
Range(Cells(1, 1), Cells(Cells(Rows.Count, 1).End(xlUp).Row, 2)).Copy
Windows("Book1.xlsx").Activate
Worksheets("Sheet1").Activate
'book1に列挿入して、そこにbook2の内容を貼りつけ
Range(Columns(3), Columns(5)).Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
Range("C1").PasteSpecial
'MATCH関数をセルに記入する（MATCH関数で総当たりチェックの代用ができる）
Cells(1, 5) = "=MATCH(A1,C:C,0)"
Cells(1, 5).Copy Destination:=Range(Cells(1, 5), Cells(Cells(Rows.Count, 3).End(xlUp).Row, 5))
'同じものがある行について、book2の内容をbook1に貼りつけ
For i = 1 To Cells(Rows.Count, 5).End(xlUp).Row
If IsNumeric(Cells(i, 5)) = True Then
Cells(i, 2) = Cells(Cells(i, 5), 4)
End If
Next i
'挿入した列を削除して元にもどす
Range(Columns(3), Columns(5)).Delete
End Sub

tatsu99 · Answer

#3です。＞'設定値＞Workbooks("TEST1.xlsx").WorkSheets("Sheet1").Range("B" & i).Value = ＞Workbooks("TEST2.xlsx").WorkSheets("Sheet1").Range("B" & j).Value なるほど、A列で一致したとき、B列の内容を設定するわけですね。このような場合は、連想配列を使うと劇的に速くなります。空白行があるということなので、空白のセルは処理しないようにしています。以下のようにしてください。 ------------------------------------------ Public Sub test_goo() Dim i As Long Dim j As Long Dim key As String Dim val As String Dim hs As Object '連想配列を作成 Set hs = CreateObject("Scripting.Dictionary") Workbooks.Open "c:\goo\TEST1.xlsx" Workbooks.Open "c:\goo\TEST2.xlsx" 'TEST2を読み込む For j = 1 To 10000 ' 空白行は処理しない If Workbooks("TEST2.xlsx").Worksheets("Sheet1").Range("A" & j).Value <> "" Then 'キーをTEST2のA列の各行の値とする（空白は処理しない） key = Workbooks("TEST2.xlsx").Worksheets("Sheet1").Range("A" & j).Value '行番号を値として記憶 val = j '連想配列にキーが未登録なら登録する If hs.exists(key) = False Then 'キーと値を登録 hs.Add key, val End If End If Next 'TEST1を処理する For i = 1 To 5000 'TEST1のA列の各行の値を取り出す key = Workbooks("TEST1.xlsx").Worksheets("Sheet1").Range("A" & i).Value '空白でなく、TEST2の値と一致するなら If key <> "" And hs.exists(key) Then 'TEST2の行番号を取り出す val = hs.Item(key) 'その行のB列をTEST1のB列へ設定する Workbooks("TEST1.xlsx").Worksheets("Sheet1").Range("B" & i).Value = Workbooks("TEST2.xlsx").Worksheets("Sheet1").Range("B" & val).Value End If Next '資源の解放 Set hs = Nothing Workbooks("TEST1.xlsx").Close Workbooks("TEST2.xlsx").Close MsgBox ("完了しました") End Sub ------------------------------------------ TEST1とTEST2のbookの絶対パスは、そちらの環境に合わせてください。 c:\goo\TEST1.xlsxは、こちらで試験したときのものです。尚、連想配列については、 http://www.seiji-tsubosaki.net/ExcelTech/ExcelVBASkillUpCollection/Contents_02.htm を参考にしました。

tatsu99 · Answer

すみません、処理時間以前の問題として、
If Workbooks("TEST1.xlsx").WorkSheets("Sheet1").Range("A" & i).Value =
Workbooks("TEST2.xlsx").WorkSheets("Sheet1").Range("A" & j) Then
Workbooks("TEST1.xlsx").WorkSheets("Sheet1").Range("A" & i).Value = 
Workbooks("TEST2.xlsx").WorkSheets("Sheet1").Range("A" & j).Value 
このコードは、TEST1とTEST2の各セルを比較して、同じなら、それをTEST1のセルへ設定してますが、
そうするとTEST1のセルは同じ値を設定するので、結局なにも変わらないようにみえます。
そうすると、なにをなさりたいのかが、良く判りません。なにをなさりたいのでしょうか？

WindFaller · Answer

こんばんは。

質問内容に、少し疑問があります。
確かに、そのようなコードでは時間が掛かります。もちろん、#1さんのコメントは、最優先課題です。

>貼り付けるTEST1.xlsxのフォーマットに癖があるため難しい状況です。

これはどういう意味でしょうか。もしも、値自体(.Value2;ReadOnly)を比較するのでしたら、フォーマットなどは一切関係ないし、もし、フォーマットで左右されるなら、そもそも、比較などできるとは思えないです。

具体的にはどういうことなのでしょうか？

いずれにしても、今の質問内容からは、あまり発展性も改良の余地もないと思います。

Hypnomatic · Answer

そのコードの１行前にApplication.ScreenUpdating = False
最終行の１行後にApplication.ScreenUpdating = True
を挟んでもダメですか？

ExcelVBA マクロの高速化について

#6の回答者ですが、

このコード実はTEST1.xlsxが一切変更されないので、

私も Dictionary を使うのに１票

#2の回答者です。

for nextの総当たりチェックは使う機会が多いですが、遅いのが欠点です。

#3です。

すみません、処理時間以前の問題として、

こんばんは。

そのコードの１行前にApplication.ScreenUpdating = False

似たような質問が見つかりました

関連するカテゴリからQ&Aを探す

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング