Excelマクロの大量行の処理速度を上げたい

質問

Excel VBA 勉強中です。
Excel VBA を利用して大量の行の処理をしたいのですが、時間がかかってしまい、場合によっては固まってしまうので困っています。

色々と調べながら自分で作ってみたのですが、少量の行で試しに行った時にはきちんと動いたのですが、大量の行で行った時には固まってしまう(動かなくなってしまう）ので困っています。

転記先(シート1)には番号とコードが入っていて、基データ(シート2)にある番号とコードが一致した場合のみ基シート(シート2)にある日付を転記先(シート1)へ転記させたいと思っています。
・シート1にもシート2にもそれぞれ、データが10000行ぐらいあります。

シート1(転記先)
D列　　　Ｅ列　　　　Ｉ列
番号　　　コード　　　日付←転記させたいセル
12345　　　123　　　　4/30
23456　　　234
34567　　　345

シート2(基データ)
B列　　　Ｇ列　　　　Ｉ列
番号　　　コード　　　日付
23456　　　123　　　　3/31
12345　　　123　　　　4/30
45678　　　345　　　　5/1

Dim sh1, sh2
Set sh1 = Sheets("シート1") 　’転記先
Set sh2 = Sheets("シート2") 　’基データ
d = sh1.Range("A65536").End(xlUp).Row
On Error Resume Next

For i = 2 To d

r = 2
d1 = sh1.Cells(i, 4) & sh1.Cells(i, 5)
d2 = sh2.Cells(r, 2) & sh2.Cells(r, 7)

Do While d2 <> ""
If d1 = d2 Then
sh1.Cells(i, 9) = sh2.Cells(r, 9)
Exit Do
End If
r = r + 1
d2 = sh2.Cells(r, 2) & sh2.Cells(r, 7)
Loop

Next i

どこがいけないのか、教えていただけると大変助かります。

回答No.4

tom04

こんばんは！
どの程度短縮できるか判りませんが・・・

ExcelでできることはExcelにやらせてみたらどうでしょうか？
ループせずにワークシート関数をそのまま利用する方法です。

Sub Sample1()
Dim i As Long, k As Long, wS1 As Worksheet, Ws2 As Worksheet
Set wS1 = Worksheets("シート1")
Set Ws2 = Worksheets("シート2")
i = wS1.Cells(Rows.Count, "D").End(xlUp).Row
k = Ws2.Cells(Rows.Count, "B").End(xlUp).Row
Application.ScreenUpdating = False
Ws2.Range("J:J").Insert '←作業列としてJ列を挿入
Range(Ws2.Cells(2, "J"), Ws2.Cells(k, "J")).Formula = "=B2&""_""&G2"
With Range(wS1.Cells(2, "I"), wS1.Cells(i, "I"))
.Formula = "=IF(COUNTIF(シート2!J:J,D2&""_""&E2),INDEX(シート2!I:I,MATCH(D2&""_""&E2,シート2!J:J,FALSE)),"""")"
.Value = .Value
End With
Ws2.Range("J:J").Delete
Application.ScreenUpdating = True
MsgBox "処理完了"
End Sub

※　Sheet1の表示形式はあらかじめ日付にしておいてください。
※　両Sheetとも10000行程度のデータ数というコトですので、数十秒はかかるかもしれません。
仮に「応答なし」になってもじっと我慢の子で
腕組みをして待ってみてください。m(_ _)m

お礼

tom04さん

お礼が大変遅くなりましてすみませんでした。
早々とお返事を頂きましてありがとうございます。

ご指摘して頂いた事を、もう少し勉強して
役立てたいと思います。

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

回答No.3

米沢 栄蔵（@YON56）

経験上から書きます。

マクロ高速化の要件
(1)ファイル操作を最小限にとどめること。
　(ファイルOpen/Save Copy&Paste は時間が懸かる。
　 Copy&Pasteよりは、データ取得&書込が速い。)
(2)Openするファイル数を最小限にとどめること。
　(不要ファイルをCloseする。)
(3)取得するデータ及び書込データをしっかり仕分けし、その保存ツールとして配列を利用する。
　(つまり、書込データを作り一気に書込--取得したデータをその都度書込手法を改める。)
(4)マクロ記述行が増えてもいいから同じ計算をさせない。
　(マクロはカッコよく記述するだが能ではない。)
(5)Application.DisplayAlerts = False Application.ScreenUpdating = Falseを使う。
　(マクロ終了時にはTrueに戻す。)
(6)Openするファイルの関数式を最小限にする。
　(関数式はOpenする際、全て再計算される。例え、=A1+B1であっても大量に存在すれば多大な時間が懸かる。)

お礼

YON56 さん

お礼が大変遅くなりましてすみませんでした。
早々とお返事を頂きましてありがとうございます。

ご指摘して頂いた事を、もう少し勉強して
役立てたいと思います。

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

回答No.2

ap_2

ANo.1の補足程度ですが、
Resize便利ですよ。Rowは範囲取得によく使うので、惜しいとこまで調べてたのでは

　data1 = sh1.Cells(1,1).Resize(d,10)　'まとめて読み
　for i = 2 to d
　　data1(i, 1) = "hoge"　'処理
　next
　sh1.Cells(1,1).Resize(d,10) = data1　'まとめて書く

セルの読み書きは、余計な内部処理が多いようで時間がかかります。特に書き込みは、都度全Book全セル関係ないとこまで再計算されるので、なるべく回数減らしたいデス。
書式とか絡むと面倒になりますが・・・

お礼

ap_2 さん
お礼が大変遅くなりましてすみませんでした。
早々とお返事を頂きましてありがとうございます。

Resizeは使った事がなかったのですが、
便利と言う事ですので、もう少し勉強して
役立てたいと思います。

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

回答No.1

aozakana_dha

提示されたコードをきちんと読んだわけではありませんが、経験上、
CellsやRangeを使用して何度もワークシートにアクセスすると遅くなります。
ですので、
(1)指定範囲内のセルの値を一括で配列に読み込み、
(2)配列上で出力値を設定したのち、
(3)指定範囲内のセルに値を一括で設定する。
というアプローチをとったほうが、処理時間を短縮できます。

次の例は、A列の値に1を足してB列に書き出すというものです。
Sub Sub1()
Dim a As Variant
Dim i As Integer
Debug.Print "start"
a = ThisWorkbook.Worksheets(1).Range("A1:A30000").Value
For i = LBound(a, 1) To UBound(a, 1)
a(i, LBound(a, 2)) = a(i, LBound(a, 2)) + 1
Next
ThisWorkbook.Worksheets(1).Range("B1:B30000").Value = a
Debug.Print "end"
End Sub

それと処理が固まってしまう件ですが、
ループの途中で
DoEvents
を入れると回避できるかと思います。

お礼

aozakana_dhaさん
お礼が大変遅くなりましてすみませんでした。
早々とお返事を頂きましてありがとうございます。

いつもCellsやRangeを主に使っていたので、
ご指摘を頂いたことをもう少し勉強して
役立てたいと思います。

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