用VBA For循环找出重名点数据巨慢

Question

VBA查找一个工作表里某列有重名的单元格、值。用for循环来实现，如果发现重名，背景设为红色。当要比较的数据比较大，如有10000个数据时，速度非常慢（无法忍受的慢）。不知道有没有办法加速。请大虾帮忙。代码如下：
Function checkDuplicate(ByVal wsName As String) As Boolean  'true ---has duplicate point
Dim ws As Worksheet
Dim ixRef, i, j, k As IntegercheckDuplicate = False
If ExistSheet(wsName) = True Then
    Set ws = ThisWorkbook.Worksheets(wsName)
    ws.Columns.ClearFormats
    ixRef = ws.Range("A65535").End(xlUp).Row 'calculate the total xref number
    For j = 3 To ixRef
        If ws.Cells(j, 1).Interior.ColorIndex = -4142 And (UCase(ws.Cells(j, 1)) = "A" Or UCase(ws.Cells(j, 1)) = "D") Then
            k = 0
            For i = j + 1 To ixRef
                If UCase(ws.Cells(i, 1)) = "A" Or UCase(ws.Cells(i, 1)) = "D" Then 
                   If UCase(ws.Cells(j, 7)) = UCase(ws.Cells(i, 7)) Then
                      checkDuplicate = True
                      ws.Cells(i, 1).Interior.ColorIndex = 3
                      k = k + 1
                   End If
                End If
            Next
            If k > 0 Then
                ws.Cells(j, 1).Interior.ColorIndex = 3
            End If
        End If
    Next
    Set ws = Nothing
End IfEnd Function

Answer 1

给你把代码优化一下
Function checkDuplicate(ByVal wsName As String) As Boolean 'true ---has duplicate point
    Dim ws As Worksheet
    Dim ixRef As Integer, i As Integer, j As Integer, k As Integer
    
    Dim c1 As String, c2 As String
    Dim strContrast As String
    
    If ExistSheet(wsName) = True Then
        Set ws = ThisWorkbook.Worksheets(wsName)
        ws.Columns.ClearFormats
        ixRef = ws.Range("A65535").End(xlUp).Row 'calculate the total xref number
        
        For j = 3 To ixRef
            If ws.Cells(j, 1).Interior.ColorIndex = -4142 Then
                c1 = UCase(ws.Cells(j, 1))
                If (c1 = "A" Or c1 = "D") Then
                    strContrast = UCase(ws.Cells(j, 7))
                    k = 0
                    For i = j + 1 To ixRef
                        c2 = UCase(ws.Cells(i, 1))
                        If c2 = "A" Or c2 = "D" Then
                            If strContrast = UCase(ws.Cells(i, 7)) Then
                                checkDuplicate = True
                                ws.Cells(i, 1).Interior.ColorIndex = 3
                                k = 1
                            End If
                        End If
                    Next
                    If k > 0 Then ws.Cells(j, 1).Interior.ColorIndex = 3
                End If
            End If
        Next
        Set ws = Nothing
    End If
End Function

Answer 2

双重循环，耗时与行数是指数关系。是否可以这样做：把 Excel 表当作 JetEngine 的外部数据库，1 首先查询数据唯一记录，连同行号存入一个 Access 临时表。2 然后查询原表中行号 Not In 临时表的所有记录。

Answer 3

临时表的查询可以一句话就解决，
--查询第一个字段出现重复的ID，其它字段同理
select field1,count(field1) as 重复次数 from tableName 
group by field1
having count(field1) >= 2

Answer 4

用字典对象进行索引，费时的表格操作可以从 O(n^2) 简化到 O(n)。
'需要添加引用：Microsoft Scripting Runtime
Function checkDuplicate(ByVal wsName As String) As Boolean
    Dim ws As Worksheet
    Dim dic As Scripting.Dictionary
    Dim ixRef As Long
    Dim i As Long
    Dim j As Long
    Dim sValue As String
    
    checkDuplicate = False    If ExistSheet(wsName) = True Then
        Set ws = ThisWorkbook.Worksheets(wsName)
        ws.Columns.ClearFormats
        ixRef = ws.Range("A65535").End(xlUp).Row    'calculate the total xref number
        
        Set dic = New Scripting.Dictionary '保存 {行号,值} 的字典
        For j = 3 To ixRef
            If (UCase(ws.Cells(j, 1)) = "A" Or UCase(ws.Cells(j, 1)) = "D") Then
                sValue = UCase(ws.Cells(j, 7))
                
                If dic.Exists(sValue) Then
                    '重复
                    checkDuplicate = True
                    '设置当前行红色
                    ws.Cells(j, 1).Interior.ColorIndex = 3
                    '设置首个重复行红色
                    i = dic.Item(sValue)
                    If i > 0 Then
                        ws.Cells(i, 1).Interior.ColorIndex = 3
                        '将行号变负数，下次不用再设红色了
                        dic.Item(sValue) = -i
                    End If
                Else
                    '不重复，则加入字典
                    dic.Add sValue, j
                End If            End If
        Next
        
        Set dic = Nothing
        Set ws = Nothing
    End IfEnd Function