用于比较两个工作表并添加缺失行的 VBA 代码

Question

我的以下代码正在运行，但需要时间（大约 10 分钟），有时它会进入无响应模式，因为我的数据大约有 60k 行。

我要做的是比较两个工作表的 A 列中的值，如果值存在于 sh2 但不存在于 sh1 中，则将整行 (A-X) 粘贴到 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=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