VBA 数万行 抽出 高速化

Question

それぞれ数万行ある2シート間でデータの突合せをしようと思うのですが、どうしても動作中に固まってしまいます。
もっと早く動くようなやり方がありましたらご教示いただけましたら幸いです。

Dim sh1 As Worksheet
    Dim sh2 As Worksheet
    Dim Start As Date
    Dim Finish As Date
    Dim lrow As Long
    Dim i As Long
    Dim n As Long
    Dim R1 As Long
    Dim R2 As Long
    Dim key, key2 As Variant
    On Error Resume Next
    Set sh1 = Worksheets("Sheet1")
    Set sh2 = Worksheets("Sheet2")

    R1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).row
    R2 = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).row
    Application.ScreenUpdating = False 
   Application.EnableEvents = False 
   Application.DisplayAlerts = False 
   Application.Calculation = xlCalculationManua '計算を手動
    For lrow = 2 To R1
      For i = 2 To R2
        key = sh1.Cells(lrow, "A").Value & "|" & sh1.Cells(lrow, "L").Value
         key2 = sh2.Cells(i, "A").Value & "|" & sh2.Cells(i, "F").Value
  
        If sh1.Cells(lrow, "AR").Value = "" And key = key2 Then
              
        sh1.Cells(lrow, "AR") = sh2.Cells(i, "AB")
               
        End If
    
    Next i
 Next lrow
    Application.StatusBar = False 
  Application.Calculation = xlCalculationAutomatic 
  Application.DisplayAlerts = True 
  Application.EnableEvents = True 
  Application.ScreenUpdating = True
    Finish = Time
    MsgBox "取得が完了しました" & vbLf & "実行"

Comments

[yureighost]

コードが正しく張り付けられてないため読み辛いですが、
ぱっと見た感じでもForを二重にして処理しているようなので、
If sh1.Cells(lrow, "AR").Value = "" And key = key2 Then
sh1.Cells(lrow, "AR") = sh2.Cells(i, "AB")
End If
の部分で一致するものが一つだとわかっているなら、
sh1.Cells(lrow, "AR") = sh2.Cells(i, "AB")
の下に
Exit For
と入れて内側のFor文を即座に抜けさせることで大分処理を軽くできます。
ただ二つ以上一致する物があると想定されていると使えませんが。

[meg_]

・コードは「コードの挿入」で記入してください。
・「どうしても動作中に固まって」というのはVBAの実行が止まるという意味でしょうか？

[hajihaji]

失礼しました。コードを入れなおしました。
ありがとうございます試してみます。
実行が止まるというのはかなり遅くエラーになるという意味です。
ありがとうございます。

[meg_]

エラーが出ているのであれば、そのエラーを掲載してください。遅いのとエラーが発生するのとでは大分違います。※ところでメモリは足りていますか？

[hajihaji]

応答していないというエラーです。デバックとかではありません。

[meg_]

ああ、エラーではなく、エクセルが固まったということですね。待てば処理が終わるということですね。

エクセルでデータ数が多いとある程度時間が掛かるのは仕方ないかもしれません。

Answer 1

If sh1.Cells(lrow, "AR").Value = "" And key = key2 Then

sh1のAR列の値が空白でないなら突合せのためのkeyをつくる必要がないので
先にAR列値の判定をしたほうが良いと思います
また効率重視するなら参照先データを配列dictionaryに格納した方が良いと思います

Sub test()
　　Dim rng1 As Range
　　Dim rng2 As Range
　　Dim R1　 As Long
　　Dim R2　 As Long
　　Dim i　　As Long
　　Dim key　As String
　　Dim dic　As Object '"scripting.dictionary"
　　Dim ret

　　'https://docs.microsoft.com/ja-jp/office/vba/language/reference/user-interface-help/dictionary-object
　　Set dic = CreateObject("scripting.dictionary")

　　'参照先Sheet2のA1:AB?範囲のうち、keyと値を配列dicに入れる
　　With Worksheets("Sheet2")
　　　　R2 = .Cells(.Rows.Count, "A").End(xlUp).Row
　　　　Set rng2 = .Range("A1:AB1").Resize(R2)
　　　　'keyが重複していたら前方優先するため逆順Loopする（後方優先なら正順）
　　　　For i = R2 To 2 Step -1
　　　　　　'1=A 6=F 28=AB
　　　　　　dic(CStr(rng2(i, 1).Value & "|" & rng2(i, 6).Value)) = rng2(i, 28).Value
　　　　Next
　　End With

　　With Worksheets("Sheet1")
　　　　R1 = .Cells(.Rows.Count, "A").End(xlUp).Row
　　　　'検索keyをつくる範囲絞込み
　　　　Set rng1 = .Range("A1:L1").Resize(R1)
　　　　'結果書き出し用
　　　　ret = .Range("AR1").Resize(R1).Value
　　　　For i = 2 To R1
　　　　　　If ret(i, 1) = "" Then
　　　　　　　　'検索key　1=A 12=L
　　　　　　　　key = CStr(rng1(i, 1).Value & "|" & rng1(i, 12).Value)
　　　　　　　　'配列dicにあれば、登録したItem（値）を持ってくる
　　　　　　　　If dic.exists(key) Then
　　　　　　　　　　ret(i, 1) = dic.Item(key)
　　　　　　　　Else
　　　　　　　　　　ret(i, 1) = "N/A"
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　'.Range("AR1").Resize(R1).Value = ret
　　　　'↓とりあえず別の列に結果書き出し。"BA1"は適宜変更してください
　　　　.Range("BA1").Resize(R1).Value = ret
　　End With
End Sub

Comments

[hajihaji]

ご回答ありがとうございます。
さっそく実行させていただきましたところ。
'結果書き出し用
ret = .Range("AR1").Resize(R1).Value
　の箇所でデバックとなりWithブロック変数が設定されておりませんと出てしまいます。
　retの宣言がないとか関係があるのでしょうか。
おそれいりますがご教示いただければ幸いにございます。

[end-u]

いや宣言はしてますけどね？
> Dim ret

Dim ret As Variant
としてねんのため型指定してみてください

それでもダメな時は変数名を変更
Dim vntAR As Variant
とでもしてモジュール内変数retを全て置換してください

[hajihaji]

Variantとしましたら動きました。
恐ろしく早くなりました。
本当にありがとうございました。