VBA 削除の速度について

お世話になっております。

削除の速度について質問させてください。

シート１A列～F列にデータが入力されています。それをシート１M列～R列に転記しています。
A列～F列のデータはシート２の表から数式で転記しています。
M列～R列への転記はボタンクリックで値のみ転記するようにしています。
A列～F列のデータに空白行がある場合もあるのですが
空白行は無視し上に詰めてM列～R列へ転記しています。
シート２に変更があればA列～F列のデータも変更され、ボタンクリックでM列～R列に登録されているデータの上書きや、一致するデータがなければ最終行に新規追加されるようにしています。

そこで不要なデータ削除ボタンを作ったのですが、
D列を検索値にし、P列に一致するデータがあれば一致した行をM列からR列まで削除する。としているのですがとても時間がかかってしまいました。削除は一応できています。

下記コードで削除しているのですが、どこが遅くさせているのでしょうか。
何か解決方法があれば教えていただきたいです。
よろしくお願いします。

一応自分でも処理速度が速くなるものを調べてやってみましたが
速度は遅いままでした。


Private Sub CommandButton1_Click()



Dim Wb1 As Workbook
Set Wb1 = Workbooks("zs.xlsm")

Dim Sh1 As Worksheet
Set Sh1 = Wb1.Worksheets("Sheet1")

Label8.Caption = "削除完了"


'★処理速度-------------------------------

With Application
.Calculation = xlCalculationManual
.EnableEvents = False
.ScreenUpdating = False
End With



'★削除-------------------------------

Dim i, i2, DROWup, PROWup As Long




i = Sh1.Range("D" & Rows.Count).End(xlUp).Row
i2 = Sh1.Range("P" & Rows.Count).End(xlUp).Row


For DROWup = i To 2 Step -1
For PROWup = i2 To 2 Step -1


If Sh1.Range("D" & DROWup).Value = Sh1.Range("P" & PROWup).Value Then


Sh1.Range(Sh1.Cells(PROWup, 13), Sh1.Cells(PROWup, 18)).Delete Shift:=xlShiftUp


End If


Next

PROWup = PROWup + 1
Next

'★処理速度-------------------------------


With Application
.Calculation = xlCalculationAutomatic
.EnableEvents = True
.ScreenUpdating = True
End With





End Sub

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2020/04/22 10:22

こんにちは

あまり考えず、処理に時間がかかりそうなコード
Sh1.Range(Sh1.Cells(PROWup, 13), Sh1.Cells(PROWup, 18)).Delete Shift:=xlShiftUp　を変えてみました。

　　For DROWup = i To 2 Step -1
　　　　For PROWup = i2 To 2 Step -1
　　　　　　If Sh1.Range("D" & DROWup).Value = Sh1.Range("P" & PROWup).Value Then
　　　　　　　　If TrgRng Is Nothing Then
　　　　　　　　　　Set TrgRng = Sh1.Range(Sh1.Cells(PROWup, "M"), Sh1.Cells(PROWup, "R"))
　　　　　　　　Else
　　　　　　　　　　'　　　　　　　　Sh1.Range(Sh1.Cells(PROWup, 13), Sh1.Cells(PROWup, 18)).Delete Shift:=xlShiftUp
　　　　　　　　　　Set TrgRng = Union(TrgRng, Sh1.Range(Sh1.Cells(PROWup, "M"), Sh1.Cells(PROWup, "R")))
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　PROWup = PROWup + 1
　　Next
　　If Not TrgRng Is Nothing Then TrgRng.Delete Shift:=xlShiftUp

速くなるかな？

この回答へのお礼

回答ありがとうございます。

直していただいたコードで素早く削除されるようになりました。
もっとコードの書き方を勉強します。
ありがとうございました。

お礼日時：2020/04/22 10:50