查找重复消息框VBAmacros
我现在有下面的代码是快速和有效的find列“A”重复。 我正在处理一个40-50,000行的非常大的数据集。 虽然这个代码是好的，但如果没有find重复的代码，它会抛出一个错误代码。
我可以通过删除“On error go to 0”行来绕过这个问题，但是它会复制粘贴整个数据集。 有没有办法修改这个代码来显示一个信息框，如果没有重复被发现？
如果不是一个单独的子将调用这个子如果重复被发现，如果不显示一个消息框？ 虽然很多数据集不够高效。
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 我不相信你的代码和你想象的一样高效。 有很多方法可以find重复项：一个是使用只能接受唯一值作为关键字的Dictionary或Collection对象; 另一个是调用Application.Match函数并testing一个正面的结果。 你的代码看起来可以兼得，所以你最好select一个或另一个。 下面的示例代码使用一个Dictionary因为它也回答了testing任何重复的问题。
您的post中还有相当多的冗余代码。 LastCol ， Rng等从未使用。
如果可以的话，最好还是避免增量调整arrays。 鉴于你知道你的字典的大小独特的价值，那么Redim可以只做一次。
您可以通过利用您的Dictionary的.Count属性来testing是否存在任何重复项 – 再次显示在下面的代码中。
所以，这是你的代码可以工作的一种方式：
更新
调整您的评论。 主要区别在于使用布尔标志来完成对重复项的testing，同时也会选取第一个和最后一个模拟对象。
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
不完全是你问，但我的免费重复主插件是优化arrays和超越正常的重复function
