vba 查找和计算重复的数量

Finding and counting number of duplicates

提问by BobSki

I have a spreadsheet with a column called NumberID that has about 50k records. I am aware that there are duplicates however with scrolling up/down it takes forever to find anything plus often times excel is being somewhat slow. I'm trying to write a quick snippet of code to be able to find and count the number of duplicates.

我有一个电子表格，其中有一列名为 NumberID 的列有大约 50k 条记录。我知道有重复，但是向上/向下滚动需要很长时间才能找到任何东西，而且通常 excel 有点慢。我正在尝试编写一个快速的代码片段，以便能够找到并计算重复的数量。

I'm trying to write a quick way of doing it, basically my data is from rows 20 to 48210 and I'm trying to find a number total duplicate records.

我正在尝试编写一种快速的方法，基本上我的数据是从第 20 行到 48210 行，我正在尝试查找总重复记录的数量。

Dim lastRow As Long
Dim matchFoundIndex As Long
Dim iCntr As Long
Dim count As Long
count = 0
lastRow = Range("B48210").End(xlUp).Row
For iCntr = 1 To lastRow
    If Cells(iCntr, 1) <> "" Then
       matchFoundIndex = WorksheetFunction.Match(Cells(iCntr, 1), Range("B20:B" & lastRow), 0)
        If iCntr <> matchFoundIndex Then
            count = count + 1
        End If
     End If
Next

MsgBox count

Here im getting an error on = WorkSheetFunction.Match - i found that this property can be used to accomplish what I'm trying to do. The error says

这里我在 = WorkSheetFunction.Match 上遇到错误 - 我发现这个属性可以用来完成我想要做的事情。错误说

Unable to get the match property for the worksheetfunction class.

无法获取工作表函数类的匹配属性。

Someone have an idea? My vba has been rusty

有人有想法吗？我的 vba 已经生锈了

采纳答案by user3598756

since you want to "count the number of duplicates", a veryfast way of doing that is exploiting RemoveDuplicates()method of Rangeobject, like follows:

因为你想“计算重复的数量”，一个非常快速的方法是利用对象的RemoveDuplicates()方法Range，如下所示：

Option Explicit

Sub main()
    Dim helperCol As Range
    Dim count As Long

    With Worksheets("IDs") '<--| reference your relevant sheet (change "IDs" to youtr actual sheet name)
        Set helperCol = .UsedRange.Resize(, 1).Offset(, .UsedRange.Columns.count) '<--| set a "helper" range where to store unique identifiers
        With .Range("A1", .Cells(.Rows.count, 1).End(xlUp)) '<-- reference "IDs" column from row 1 (header) to last not empty cell
            helperCol.Value = .Value '<--| copy identifiers to "helper" range
            helperCol.RemoveDuplicates Columns:=1, Header:=xlYes '<--| remove duplicates in copied identifiers
            count = .SpecialCells(xlCellTypeConstants).count - helperCol.SpecialCells(xlCellTypeConstants).count '<--| count duplicates as the difference between original IDs number and unique ones
        End With
        helperCol.ClearContents '<--| clear "helper" range
    End With
    MsgBox count & " duplicates"
End Sub

回答by Comintern

Using Matchfor this is incredibly inefficient that many rows. I'd fill a Dictionarywith found items and just test to see if you've seen them before:

使用Match这么多行是非常低效的。我会Dictionary用找到的项目填充一个，然后测试一下你以前是否见过它们：

'Add a reference to Microsoft Scripting Runtime.
Public Sub DupCount()
    Dim count As Long
    With New Scripting.Dictionary
        Dim lastRow As Long
        lastRow = Range("B48210").End(xlUp).Row
        Dim i As Long
        For i = 1 To lastRow
            Dim test As Variant
            test = Cells(i, 2).Value
            If IsError(test) Then
            ElseIf test <> vbNullString Then
                If .Exists(test) Then
                    count = count + 1
                Else
                    .Add test, vbNull
                End If
            End If
        Next
    End With
    MsgBox count
End Sub

回答by brettdj

You can use my Duplicate Masteer addinto do this.

您可以使用我的Duplicate Master 插件来执行此操作。

It offers a fast array method to deal with duplicates.

它提供了一种快速的数组方法来处理重复项。

• counting
• deleting
• selecting

• 数数
• 删除
• 选择

It goes beyond the built-in features of Excel as it allows duplicate matching on a

它超越了 Excel 的内置功能，因为它允许重复匹配

1. case insentitive basis
2. ignoring whitespace
3. even RegexPmatching
4. runs over multiple sheets

1. 不区分大小写的基础
2. 忽略空格
3. 甚至RegexP匹配
4. 在多张纸上运行