VBA - Doループ＋各行をコピペするマクロを高速化したい

Question

VBA - Doループ＋各行をコピペするマクロを高速化したい

以下のマクロを作成しましたが、50行程度あるシートに対し処理を実行～完了するまで約10秒程度かかってしまいます。
シンプルなコードなので、なぜここまで時間がかかってしまうのか、、悩んでいます。

今後、対象データが1000件以上になるケースが想定されるため、処理速度をより高速化したく。
改善方法をご助言頂けますと幸いです。

ちなみに、コード中に記載のとおり、以下はすでに試しました。

• Application.ScreenUpdating = Falseにして処理を実行する
• 貼付け時、「値のみの貼付け」をする .PasteSpecial Paste:=xlPasteValues

OSはWindows 10、
Excelバージョンは、Microsoft Excel for Office 365 64bit です

マクロの内容

シートws2のA列セルの値（仮にcells(j, "A")とする)の中で、シートws1のA列セルの値（仮にcells(i, "A")とする)と一致するものがあるとき、
range("A" & j, "BA" & j)をRange("A" & i, "BA" & i)にコピペする
一致するものがない場合のみ、range("A" & j, "BA" & j)をシートws1の一番下の空欄列にコピペする

コード

Public ws1 As Worksheet
Sub test()

Dim ws2 As Worksheet

Set ws1 = ThisWorkbook.Worksheets("ws1")
Set ws2 = ThisWorkbook.Worksheets("ws2")

Dim i As Double
Dim j As Double
Dim lastRow As Double
Dim updated As Boolean

Application.ScreenUpdating = False

i = 2

Do Until ws2.Cells(i, "A").Value = ""
    
    updated = False
    
    j = 5
    
    Do Until ws1.Cells(j, "A").Value = ""
    
        If ws2.Cells(i, "A").Value = ws1.Cells(j, "A").Value Then
            ws2.Range("A" & i, "BA" & i).Copy
            ws1.Range("A" & j).PasteSpecial Paste:=xlPasteValues
            
            updated = True
            Exit Do
        End If
        j = j + 1
    Loop
    
    If updated = False Then
        lastRow = ws1.Cells(4, "A").End(xlDown).Row
        ws2.Range("A" & i, "BA" & i).Copy
        ws1.Range("A" & lastRow + 1).PasteSpecial Paste:=xlPasteValues
    End If
    
    i = i + 1
Loop

Application.ScreenUpdating = True

End Sub

Answer 1

50行ぐらいで10秒かかるとすると、セルに関数が多数設定されていませんか。
更新するたびに再計算が実行されるので重くなります。
自動計算を停止すると改善するかもしれません。

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual    ' 手動計算にする

'ループ処理

Application.Calculation = xlCalculationAutomatic ' 自動計算にする
Application.ScreenUpdating = True

これで改善しないなら、Copy と PasteSpecial も重い処理ですので、Valueプロパティでの代入に変更すると改善する可能性があります。

Office TANAKA - VBA高速化テクニック[値貼り付けは遅い]

            ws2.Range("A" & i, "BA" & i).Copy
            ws1.Range("A" & j).PasteSpecial Paste:=xlPasteValues

上記の部分を下記に修正してみてください。

    with ws2.Range("A" & i, "BA" & i)
        ws1.Range("A" & j).Resize(1, .Columns.Count).Value = .Value
    End with

他のPasteSpecialも同様に修正してみてください。

Comments

[koyamashinji]

ご回答誠に有難うございます。
関数が設定されているセルはないので、Copy＆PasteをValueプロパティでの代入に変更すると劇的に高速化しました。
こんなにも違うのですね。大変驚きました。

ただ、
with ws2.Range("A" & i, "BA" & i)
ws1.Range("A" & j).Resize(1, .Columns.Count).Value = .Value
End with

にすると、「rangeメソッドは失敗しました worksheetオブジェクト」のエラーが出たので（なぜかは分からない・・）
Resizeメソッドに何かしら問題があるのだと勝手に推測し、以下のとおり貼付け先の範囲を指定したところ、問題なく動きました。

with ws2.Range("A" & i, "BA" & i)
ws1.Range("A" & j, "BA" & j).Value = .Value
End with

にすると、「rangeメソッドは失敗しました worksheetオブジェクト」のエラーが出たので（なぜかは分からない・・）
Resizeメソッドに何かしら問題があるのだと勝手に推測し、以下のとおり貼付け先の範囲を指定したところ、問題なく動きました。

with ws2.Range("A" & i, "BA" & i)
ws1.Range("A" & j, "BA" & j).Value = .Value
End with

Answer 2

１セルずつとるのではなく２次元配列でまとめてとりましょう！

参考：http://officetanaka.net/excel/vba/speed/s11.htm

Comments

[koyamashinji]

ご回答頂き有難うございます。２次元配列でまとめる方法もあるのですね・・参考になりました。