VBA 删除重复代码更快

Question

但是，目前使用此代码，我有大量数据，因此运行速度非常慢。我需要删除任何重复的信息，并保留最高行的信息。

dim dup as variant, r as long, lncheckduplicatescolumn as long
With wb_DST.Sheets(sWs_DST)
     lncheckduplicatescolumn = .Cells(.Rows.Count, "A").End(xlUp).row
     for r = lncheckduplicatescolumn  to 2 step -1
         dup = application.match(.cells(r, "A").value, .columns(1), 0)
             if dup < r then .rows(dup).delete
     next r
end with

数据:

       Column A              Column B
          A                      1
          B                      2
          C                      3
          A                      3

结果应该是:

           B                     2
           C                     3
           A                     3

A列中数据的顺序无关紧要，只要它是唯一的，并保留较高行号中的信息。虽然我分享的代码有效，但对于大型数据集来说太慢了。

Answer 1

另一种快速方法是使用 Dictionary目的。您可以检查 A 列中的任何值是否已存在于 Dictionary 中。 .如果他们这样做(意味着它是重复的)，那么不要每次都删除它们，这会增加代码的运行时间。相反，您可以使用 DelRng对象，它是 Range使用 Union合并多个重复的行。

稍后，您可以使用 DelRng.Delete 一次删除整个重复范围。 .

代码

Option Explicit

Sub RemoveDuplicatesUsingDict()

Dim wb_DST As Workbook
Dim sWs_DST As String

'  Dictionary variables
Dim Dict As Object
Dim DictIndex As Long, ExistIndex As Long

Dim DelRng As Range
Dim LastRow As Long, i As Long

' --- parameters for my internal testing ---
Set wb_DST = ThisWorkbook
sWs_DST = "Sheet1"

Application.ScreenUpdating = False

Set Dict = CreateObject("Scripting.Dictionary")

With wb_DST.Sheets(sWs_DST)
     LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row ' get last row with data in column "A"

     For i = LastRow To 2 Step -1
        If Not Dict.exists(.Range("A" & i).Value) Then ' value doesn't exists yet in Dictionary >> add this Key
            Dict.Add .Range("A" & i).Value, .Range("A" & i).Value
        Else ' value already exists in Dictionary >> add it to DelRng (later will delete the entire range)
            If Not DelRng Is Nothing Then
                Set DelRng = Application.Union(DelRng, .Rows(i)) ' add current row to existing DelRng
            Else
                Set DelRng = .Rows(i)
            End If
        End If
     Next i
End With

' delete the entire range at 1-shot
If Not DelRng Is Nothing Then DelRng.Delete

Application.ScreenUpdating = True

End Sub