VBA 処理を軽くしたい 【シート間データ移行】

Question

Excelでシート間のデータ移行プログラムをＶＢＡで書いていますが処理が遅く
Excelアプリが落ちてしまうことがあります。
処理を軽くするにはどのようなコードに変更すると良いでしょうか。
ご教示お願いいたします。

やりたいことは以下の通りです。
Sheet1に膨大なデータ（５万行ほど）がありその中から
必要なデータをSheet2に移行します。

Sheet1のデータの内、【品物】→冷蔵庫　　【番号】→A007　というデータの担当・室温をSheet2に移行する。
移行先の行の指定はSheet1の時間と比較し、同じ時間が入力されている行とする。

生データと移行後のサンプル画像とコードを添付いたしましたのでご参照ください。
何卒宜しくお願いいたします。

質問投稿後コメント欄にアドバイスをいただき
【For文を１つにまとめる】【dictionary活用】２方法を教えて頂きました。現在変更中です・・・・
その他アドバイスありましたら引き続き教えて頂けますと幸いです。

コード
Application.ScreenUpdating = False

Dim 時間 As String
Dim 品物 As String
Dim 番号 As String
Dim 室温 As String
Dim 担当 As String

Dim 品物A As String
Dim 番号A As String
Dim 時間A As String
品物A = "冷蔵庫"
番号A = "A007"

    
Dim LASTROW As Long
Dim LASTROW2 As Long
LASTROW = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
LASTROW2 = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row

Dim i As Long
Dim k As Long
    For i = 2 To LASTROW
        時間 = Worksheets("Sheet1").Cells(i, 1).Value
        品物 = Worksheets("Sheet1").Cells(i, 2).Value
        番号 = Worksheets("Sheet1").Cells(i, 3).Value
        室温 = Worksheets("Sheet1").Cells(i, 4).Value
        担当 = Worksheets("Sheet1").Cells(i, 5).Value
        
            If 品物 = 品物A And 番号 = 番号A Then
                
                For k = 2 To LASTROW2
                    時間A = Worksheets("Sheet2").Cells(k, 1).Value
                    
                    If 時間 = 時間A Then
                        Worksheets("Sheet2").Cells(k, 2).Value = 室温
                        Worksheets("Sheet2").Cells(k, 3).Value = 担当
                    End If
                Next k
            End If
    Next i

Application.ScreenUpdating = True

Comments

[meg_]

> 処理が遅く
Excelアプリが落ちてしまうことがあります
遅いこととExcelが異常終了することは関係あるのでしょうか？

[sousuke]

全体をシート2にコピーして該当以外の室温と担当者を消してはどうですか？

[riko]

sousuke様　
ご回答ありがとうございます。
シート２にはこの前後も行っている処理がありまして
様々なデータが入力されている　＆　入力予定です

そのため今回の転記データのみを残して他を削除するというのは困難です。

[riko]

meg様
質問ありがとうございます。
今回のプログラムは
①毎回処理が遅い
②アプリが落ちてしまうことが５回に１回ほど

上記のような状況です。
①、②に関係があるかはわかりません

[meg_]

メモリの使用状況は確認されましたか？

[tatsu99]

Sheet1とSheet２の時刻の並びが同じであり、今後もかわらないという前提ですが、
Sheet1の行番号を示すiとSheet2の行番号を示すkとの間には、
k=i+1という関係があります。
従って、
for k=2 to LASTROW2で該当時刻を探すのではなく、
k=i+1とし、
Worksheets("Sheet2").Cells(k, 2).Value = 室温
Worksheets("Sheet2").Cells(k, 3).Value = 担当
としては、いかがでしょうか。
今後、時刻の並びが変わる可能性があるなら、その旨補足ください。
その場合は、dictionaryを使用する方法があります。

[riko]

tatsu99様
コメントありがとうございます。
１つのFor文にまとめる方法　可能なので挑戦してみます。
dictionaryはあまり使用経験がないので調べて活用してみます。
ありがとうございます。

[riko]

meg 様
メモリの使用状況については確認していません。
確認する理由があまりわからないのですが
どういった理由でしょうか？
質問に質問を返す形で申し分けありません。

[meg_]

> Excelアプリが落ちてしまうことがあります
上記の原因がメモリ不足にあるのではないか？と疑ったからです。

[riko]

meg様
メモリ不足が原因だとわかった場合どのような対処になるのでしょうか？
プログラムの実行がアプリ落ちのトリガーなのは明白なので
プログラムの内容を変更し、処理を軽くする方向の改善しかないと考えていました。
※今回投稿したプログラム以外のプログラム実行は問題なく処理されています
また質問で申し訳ありません。

[sazi]

> 移行先の行の指定はSheet1の時間と比較し、同じ時間が入力されている行とする。

「Sheet2の時間の並びおよび個数はSheet1と同じとは限らない」でしょうか？

[meg_]

> プログラムの内容を変更し、処理を軽くする方向の改善しかないと
｢処理を軽く｣とはどういう意味でしょうか？文言からは"メモリ使用量を少なく"と解釈しましたが、質問者さんの意図とは違うようなので確認したいです。

> メモリ不足が原因だとわかった場合どのような対処になるのでしょうか？
アプリが落ちる原因を特定しないと分かりません。

[riko]

meg様
①
＞｢処理を軽く｣とはどういう意味でしょうか？文言からは"メモリ使用量を少なく"と解釈しましたが
について
→処理を軽くは【メモリ使用量を少なく】という解釈でオッケーです。

②
＞アプリが落ちる原因を特定しないと分かりません。
について
meg様から【アプリが落ちる原因はメモリ不足にあるのではないか？】
という趣旨の助言を頂いたと思います。
そこで私は
アプリが落ちる原因がメモリ不足だと特定できた場合、どのような対処が考えられますか？
と質問させて頂いた次第です。

[meg_]

>＞アプリが落ちる原因を特定しないと分かりません。
どこでメモリ不足が発生しているのか？によって具体的な方法は変わると思います。仮定を重ねた質問への回答は難しいです。

[riko]

今回の結論としては
皆様のアドバイスを参考にプログラムの内容を変更することで
処理が速くなり、アプリが落ちる現象もなくなりました。
ありがとうございます

Answer 1

dictionaryを使用した例です。一応、動作確認しています。

Public Sub 室温担当者設定()
    Application.ScreenUpdating = False
    Dim dicT As Object
    Dim 時間 As String
    Dim 品物 As String
    Dim 番号 As String
    Dim 室温 As String
    Dim 担当 As String

    Dim 品物A As String
    Dim 番号A As String
    Dim 時間A As String
    Dim i As Long
    Dim k As Long
    品物A = "冷蔵庫"
    番号A = "A007"
    Set dicT = CreateObject("Scripting.Dictionary")
    

    Dim LASTROW As Long
    Dim LASTROW2 As Long
    LASTROW = worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    LASTROW2 = worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row
    For k = 3 To LASTROW2
        時間A = worksheets("Sheet2").Cells(k, 1).Value
        dicT(時間A) = k
    Next


    For i = 2 To LASTROW
        時間 = worksheets("Sheet1").Cells(i, 1).Value
        品物 = worksheets("Sheet1").Cells(i, 2).Value
        番号 = worksheets("Sheet1").Cells(i, 3).Value
        室温 = worksheets("Sheet1").Cells(i, 4).Value
        担当 = worksheets("Sheet1").Cells(i, 5).Value

        If 品物 = 品物A And 番号 = 番号A Then
            If dicT.exists(時間) = True Then
                k = dicT(時間)
                worksheets("Sheet2").Cells(k, 2).Value = 室温
                worksheets("Sheet2").Cells(k, 3).Value = 担当
            End If
        End If
    Next i

    Application.ScreenUpdating = True
End Sub

Comments

[riko]

tatsu99様
素早い回答ありがとうございます。
実践してみます！！

[tatsu99]

worksheets("Sheet2").Cells(k, 2).Value = 室温
worksheets("Sheet2").Cells(k, 3).Value = 担当
のインデントがずれてましたので、修正しておきました。

[riko]

tatsu99様
丁寧に添削頂きありがとうございます。