VBA 代碼比較兩個工作表並添加缺少的行

Question

我有下面的代碼正在工作但需要時間（大約 10 分鍾），有時它會進入無響應模式，因為我的數據有大約 60k 行。

我要做的是比較兩個工作表的 A 列中的值，如果值存在於 sh2 中但不存在於 sh1 中，則將整行（AX）粘貼到 sh1 中。

如果有比這更好、更快、更有效的方法，有人可以幫忙嗎？

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Set sh1 = Workbooks(WK1).Sheets(sheet1)
Set sh2 = Workbooks(WK2).Sheets(sheet1)
    For Each c In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
        If Application.CountIf(sh1.Range("A:A"), c.Value) = 0 Then
            c.Resize(, 24).Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
        End If
    Next
End Sub

Answer 1

嘗試在開始時添加Application.ScreenUpdate=False Application.EnableEvents = False在代碼結束時添加 Application.ScreenUpdate Application.ScreenUpdate=True Application.EnableEvents = True 。 它應該加速整個代碼。 如下所示。 您可以添加帶有進度條的用戶表單以顯示實際狀態。

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Application.ScreenUpdate=False
Application.EnableEvents = False
Set sh1 = Workbooks(WK1).Sheets(sheet1)
Set sh2 = Workbooks(WK2).Sheets(sheet1)
For Each c In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
    If Application.CountIf(sh1.Range("A:A"), c.Value) = 0 Then
        c.Resize(, 24).Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
    End If
Next
Application.ScreenUpdate=True 
Application.EnableEvents = True
End Sub

\\ 已編輯 \\

試試下面的代碼。 沒有必要通過每個車道的工作表功能檢查所有范圍。 find 方法更快

Sub t()
Dim sh1 As Worksheet, sh2 As Worksheet, c As Range
Dim str_LookUp As String, rng_FindRange As Range
Application.ScreenUpdating = False
Application.EnableEvents = False
Set sh1 = Workbooks(WK1).Sheets(sheet1)
Set sh2 = Workbooks(WK2).Sheets(sheet1)
For Each c In sh2.Range("A2", sh2.Cells(Rows.Count, 1).End(xlUp))
str_LookUp = c.Text
Set rng_FindRange = sh1.Range("A:A").Find(str_LookUp, , , xlWhole)
If rng_FindRange Is Nothing Then
    c.Resize(, 24).Copy sh1.Cells(Rows.Count, 1).End(xlUp)(2)
End If
Next
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub