查找重复消息框 VBA 宏

Question

我目前在下面的代码可以快速有效地在“A”列中查找重复项。我正在处理一个非常大的数据集 40-50,000 行有时更多。虽然这段代码很好，但如果没有找到重复项，它会抛出错误代码。

我可以通过删除“On error go to 0”行来规避这个问题，但它会复制粘贴整个数据集。如果没有找到重复项，有没有办法修改此代码以显示消息框？

如果不是，如果找到重复项并且如果不显示消息框，则可能会有一个单独的 Sub 调用此 Sub？尽管对于大型数据集，许多效率不够。

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 1

我不相信你的代码有你想象的那么高效。有多种查找重复项的方法：一种是使用Dictionary 或Collection 对象，它只能接受唯一值作为其键；另一种是调用Application.Match 函数并测试阳性结果。您的代码似乎两者兼而有之，因此您最好选择其中一个。下面的示例代码使用Dictionary，因为它还回答了有关对其进行重复测试的问题。

您的帖子中还有很多冗余代码。 LastCol、Rng 等从未使用过。

如果可以，最好也避免逐步重新调整阵列。鉴于您知道唯一值字典的大小，那么 Redim 可以只执行一次。

您可以通过利用 Dictionary 的 .Count 属性来测试是否存在任何重复项 - 再次，如下面的代码所示。

所以，这是您的代码可以工作的一种方式：

更新

根据您的评论进行调整。主要区别在于重复测试是使用布尔标志完成的，但也会选择第一个和最后一个重复。

Dim wsData As Worksheet, wsOutput As Worksheet
Dim keyRefs As Object, dupes As Object
Dim keyF As String, keyL As String
Dim i As Long, j As Long
Dim data As Variant, output() As Variant, r As Variant
Dim dupesFound As Boolean

'Set application values temporarily.
With Application
    .Calculation = xlCalculationManual
    .EnableEvents = False
    .ScreenUpdating = False
End With

'Assign worksheet object.
Set wsData = Worksheets("Sheet1")
On Error Resume Next
Set wsOutput = Sheets("Duplicate Data")
On Error GoTo 0
If Not wsOutput Is Nothing Then
    wsOutput.Cells.Clear
Else
    ThisWorkbook.Sheets.Add(After:=wsData).Name = "Duplicate Data"
    Set wsOutput = ActiveSheet
End If

'Read data into array.
With wsData
    data = .Range(.Cells(4, "A"), _
           .Cells(.Rows.Count, "A").End(xlUp)) _
           .Resize(, 23).Value2
End With

'Gather the non-duplcate index numbers.
Set keyRefs = CreateObject("Scripting.Dictionary")
Set dupes = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(data, 1)
    keyF = CStr(data(i, 1))
    If Not keyRefs.Exists(keyF) Then
        keyRefs.Add keyF, i
    Else
        If Not dupesFound Then dupesFound = True
        keyL = CStr(data(i, 1)) & "|L"
        If Not dupes.Exists(keyF) Then
            dupes.Add keyF, keyRefs(keyF)
            dupes.Add keyL, i
        Else
            dupes(keyL) = i
        End If
    End If
Next

'Read each unique index from data array to output array,
'and write to sheet.
If dupesFound Then 'this tests if you have any duplicates
    ReDim output(1 To dupes.Count, 1 To UBound(data, 2))
    i = 1
    For Each r In dupes.items
        For j = 1 To UBound(data, 2)
            output(i, j) = data(r, j)
        Next
        i = i + 1
    Next
    With wsOutput
        .Range("A3:V3").Value = wsData.Range("A3:V3").Value2
        .Range("A4").Resize(UBound(output, 1), UBound(output, 2)).Value = output
        With .Sort
            .SortFields.Clear
            .SortFields.Add Key:=wsOutput.Range("A3"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
            .SetRange wsOutput.Range("A3").Resize(UBound(output, 1) + 1, UBound(output, 2))
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
    End With
Else
    MsgBox "No duplicates found."
End If

'Reset application values.
With Application
    .Calculation = xlCalculationAutomatic
    .EnableEvents = True
    .ScreenUpdating = True
End With

Answer 2

不完全符合您的要求，但我的免费 Duplicate Master addin 针对数组进行了优化，超出了正常的重复功能