Question

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

稍后我将使用这些副本复制到另一张表。数据从＃34; A3＆＃34;列开始。到＆＃34; V3＆＃34;并使用最后一行。数据范围从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

Answer 1

您可以使用数据透视表来显示项目的计数，只需从空白和1个计数项目中删除过滤器，这里是您的重复值列表。您可以使用VBA自动完成此过程。

Answer 2

autofilter负责慢速运行代码。唯一项目的数量都会影响代码的速度。

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

下面给出的代码将添加一个名为＆＃34; Duplicate Data＆＃34;使用所有重复数据并在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

Answer 3

在工作表的最后一列中写一个公式，该列将返回记录的RowNumber。这意味着第一次找到记录时它返回1.第二次返回2，第三次返回3，等等。

一旦你有了这个公式，你可以在vba中自动化这个部分。

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

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

优化VBA / Excel宏代码（查找重复项和排序大数据集）

3 个答案: