优化 VBA/Excel 宏代码（查找重复项和对大型数据集进行排序）答案

【问题标题】：Optimizing VBA / Excel Macro Code (Finding Duplicates and Sorting Large Data Set )优化 VBA/Excel 宏代码（查找重复项和对大型数据集进行排序）
【发布时间】：2017-10-24 05:29:21
【问题描述】：

我目前编写了一个代码来查找从“A3”范围开始到使用的最后一行的重复值；突出显示重复的红色，包括第一个和最后一个实例；按突出显示的颜色过滤，最后从小到大排序。

稍后我将使用这些副本复制到另一张纸上。数据从“A3”列开始到“V3”列和最后一行使用。数据范围从 10,000 到 40,000 行不等，可能更多，具体取决于接收到的数据。

我的问题是这个 marco 运行速度非常慢，有时会死机。有没有其他方法可以达到同样的效果，但更有效、更快？

Sub filtersort ()

Dim sht As Worksheet
Set sht = Worksheets("Sheet1")

Lastrow = Range("A" & Rows.Count).End(xlUp).Row
N = Cells(Rows.Count, "A").End(xlUp).Row

sht.Range("A3:A" & Lastrow).Select

Selection.FormatConditions.AddUniqueValues

Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).DupeUnique = xlDuplicate
With Selection.FormatConditions(1).Font
    .Color = -16383844
    .TintAndShade = 0
End With

With Selection.FormatConditions(1).Interior
    .PatternColorIndex = xlAutomatic
    .Color = 13551615
    .TintAndShade = 0

End With

Selection.FormatConditions(1).StopIfTrue = False
sht.Range("A3:A" & Lastrow).Select
Application.CutCopyMode = False
Selection.AutoFilter
ActiveSheet.Range("$A$3:$A$" & Lastrow).AutoFilter Field:=1, Criteria1:=RGB(255, _
    199, 206), Operator:=xlFilterCellColor

sht.Range("A3:V" & N).Sort Key1:=Range("A1"), Order1:=xlDescending, Header:=xlYes

End Sub

【问题讨论】：

标签： vba excel duplicates

【解决方案1】：

自动过滤器负责缓慢运行的代码。唯一项的数量都会影响代码的速度。

如果您的意图是检索已排序的重复数据，您可以尝试这种方法。

下面给出的代码将添加一个名为“重复数据”的新工作表，其中包含所有重复数据，并在 A 列上对其进行排序。

代码假定数据在名为 Sheet1 的工作表上，第 3 行是标题行，实际数据从第 4 行开始。

根据需要进行修改。

Sub filtersort()

Dim wsData As Worksheet, wsOutput As Worksheet
Dim Rng As Range
Dim LastRow As Long, LastCol As Long, i As Long, j As Long, n As Long
Dim arr(), x, dict, arrOut()

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

Set wsData = Worksheets("Sheet1")

On Error Resume Next
Set wsOutput = Sheets("Duplicate Data")
wsOutput.Cells.Clear
On Error GoTo 0

If wsOutput Is Nothing Then
    Sheets.Add(after:=wsData).Name = "Duplicate Data"
    Set wsOutput = ActiveSheet
End If
LastRow = wsData.Range("A" & Rows.Count).End(xlUp).Row
LastCol = wsData.Cells(3, Columns.Count).End(xlToLeft).Column + 1

Set Rng = wsData.Range("A3:A" & LastRow)

x = wsData.Range("A4:V" & LastRow).Value
Set dict = CreateObject("Scripting.Dictionary")

For i = 1 To UBound(x, 1)
    If Not dict.exists(x(i, 1)) Then
        dict.Item(x(i, 1)) = ""
    Else
        j = j + 1
        ReDim Preserve arr(1 To j)
        arr(j) = x(i, 1)
    End If
Next i

ReDim arrOut(1 To UBound(x, 1), 1 To UBound(x, 2))
For i = 1 To UBound(x, 1)
    If Not IsError(Application.Match(x(i, 1), arr, 0)) Then
        n = n + 1
        For j = 1 To UBound(x, 2)
            arrOut(n, j) = x(i, j)
        Next j
    End If
Next i

wsData.Range("A3:V3").Copy wsOutput.Range("A3")

wsOutput.Range("A4").Resize(n, UBound(x, 2)).Value = arrOut

LastRow = wsOutput.Cells(Rows.Count, 1).End(xlUp).Row

wsOutput.Range("A3:V" & LastRow).Sort Key1:=wsOutput.Range("A4"), Order1:=xlDescending, Header:=xlYes
With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With
End Sub

【讨论】：

哇！这是一个很大的进步，非常感谢。我唯一的问题是在将重复数据从“sheet1”传输到“重复数据”时保持数字格式和值相同。
另外，在这些副本被转移之后；有没有一种有效的方法来删除第一张表中的重复项？我会在另一个宏中这样做。
您可以使用单独的代码将列的格式复制到输出表，并在代码将数据写入其中后调用它。
您可以根据您的下一个要求打开一个新问题。 :)
对您提供的代码的快速跟进问题；当使用的数据集包含重复时，它运行完美，尽管当输入没有重复的数据集时我收到错误并且代码没有运行。关于如何解决这个问题的任何想法？

【解决方案2】：

您可以使用数据透视表来获取项目计数，然后从空白和 1 个计数项目中删除过滤器，这是您的重复值列表。您可以使用 VBA 自动执行此过程。

【讨论】：

【解决方案3】：

在工作表的最后一列中编写一个公式，该公式将返回记录的行号。这意味着第一次找到记录时返回 1。第二次返回 2，第三次返回 3，以此类推。

一旦你的公式正确，你就可以在 vba 中自动化这部分。

现在按此列对数据进行排序。

在 rowNumber>1 处批量剪切和粘贴。很多次我看到类似的事情，人们在 vba 中逐行处理它。比在工作簿中使用公式要慢得多。分拣和切割。

【讨论】：