用VBA实现单元格内相同项数字设置为红色

laoau128

用VBA实现单元格内相同项数字设置为红色

laoau128

Sub test()
    Dim myRng As Range, arr, ar, i&, x$, Rng As Range, myDress$, tempArr, temp, brr(), Q&
    Set myRng = Range("A1:a6")
    ReDim brr(1 To 1000, 1 To 4)
    '--------------------------------------------------
    Set regex1 = CreateObject("VBSCRIPT.REGEXP")    'RegEx为建立正则表达式
    With regex1
        .Global = True    '设置全局可用
        .Pattern = "[0-9A-Z]+"
    End With
    '--------------------------------------------------
    Dim d As Object, dic As Object
    Set d = CreateObject("scripting.dictionary")
    Set dic = CreateObject("scripting.dictionary")
    '--------------------------------------------------

    For Each Rng In myRng
        ar = Rng.Value
        myDress = Rng.Address
        Set c = regex1.Execute(ar)

        If c.Count > 0 Then
            For i = 0 To c.Count - 1
                x = c.Item(i).Value
                If IsNumeric(x) = True And d.exists(x) = True Then
                    Q = Q + 1
                    brr(Q, 1) = myDress
                    brr(Q, 2) = x
                    brr(Q, 3) = c.Item(i).firstindex + 1
                    Q = Q + 1
                    brr(Q, 1) = d(x)(0)
                    brr(Q, 2) = d(x)(1)
                    brr(Q, 3) = d(x)(2)
                End If
                d(x) = Array(myDress, x, c.Item(i).firstindex + 1)

            Next i
        End If
    Next
    '-------------------------------------------------
    If Q > 0 Then
        For i = 1 To Q
            With Range(brr(i, 1))
                .Characters(Start:=brr(i, 3), Length:=Len(brr(i, 2))).Font.ColorIndex = 3
            End With
        Next i
    End If
    '--------------------------------------------------

End Sub