求助请大神帮助

Jerry6455

这是表的表头，里面有十万条数据，我想用VBA的方式查找里面A列银行卡号或者查找B列身份证号，他们的数据列中是否有重复一致的好吗，如果有的话，用黄色或者其他颜色显示出来。我用公式弄太慢了，好久都不能出来，而且还不是很准确。有大神能帮助我吗

shiruiqiang

模拟数据都没啊

清风竹-

DeepSeek生成的代码。

ykcbf1100

不难，但没附件就算了。

书法爱好者

Sub 颜色标识重复值()     Dim ws As Worksheet     Dim rng As Range     Dim lastRow As Long, lastCol As Long     Dim dict As Object     Dim cell As Range     Dim key As String     Dim i As Long, j As Long     Set ws = ActiveSheet     lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row                    Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1))     rng.FormatConditions.Delete     Set dict = CreateObject("Scripting.Dictionary")     Application.ScreenUpdating = False     Application.Calculation = xlCalculationManual     Application.EnableEvents = False         dict.RemoveAll         If Application.CountA(ws.Columns(1)) > 0 Then                         For i = 1 To lastRow                 If Not IsEmpty(ws.Cells(i, 1)) Then                     key = CStr(ws.Cells(i, 1).Value)                     If dict.Exists(key) Then                         dict(key) = dict(key) + 1                     Else                         dict.Add key, 1                     End If                 End If             Next i                                      For i = 1 To lastRow                 If Not IsEmpty(ws.Cells(i, 1)) Then                     key = CStr(ws.Cells(i, 1).Value)                     If dict(key) > 1 Then                         ws.Cells(i, 1).Interior.Color = RGB(255, 199, 206)                         ws.Cells(i, 1).Font.Color = RGB(156, 0, 6)                     End If                 End If             Next i         End If          Application.ScreenUpdating = True     Application.Calculation = xlCalculationAutomatic     Application.EnableEvents = True     MsgBox "处理完成！共处理 " & lastRow & " 行数据。" End Sub

书法爱好者

Sub 颜色标识重复值()
    Dim ws As Worksheet
    Dim rng As Range
    Dim lastRow As Long, lastCol As Long
    Dim dict As Object
    Dim cell As Range
    Dim key As String
    Dim i As Long, j As Long
    Set ws = ActiveSheet
    lastRow = ws.Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
   
   
   
    Set rng = ws.Range(ws.Cells(1, 1), ws.Cells(lastRow, 1))
    rng.FormatConditions.Delete
    Set dict = CreateObject("Scripting.Dictionary")
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
        dict.RemoveAll
        If Application.CountA(ws.Columns(1)) > 0 Then
           
            For i = 1 To lastRow
                If Not IsEmpty(ws.Cells(i, 1)) Then
                    key = CStr(ws.Cells(i, 1).Value)
                    If dict.Exists(key) Then
                        dict(key) = dict(key) + 1
                    Else
                        dict.Add key, 1
                    End If
                End If
            Next i
            
           
            For i = 1 To lastRow
                If Not IsEmpty(ws.Cells(i, 1)) Then
                    key = CStr(ws.Cells(i, 1).Value)
                    If dict(key) > 1 Then
                        ws.Cells(i, 1).Interior.Color = RGB(255, 199, 206)
                        ws.Cells(i, 1).Font.Color = RGB(156, 0, 6)
                    End If
                End If
            Next i
        End If
   
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    MsgBox "处理完成！共处理 " & lastRow & " 行数据。"
End Sub