求老师解决一下这种颜色标注的问题

wjs521

这个以A列数字为参照物，除了A列以外的   对应每一行   只要每行的单元格内含有A列单元格内的数字  就自动变红

如图所示

这个我用突出规则来进行标注  没法进行  希望哪位老师帮忙用VBA一键解决

gwjkkkkk

Option Explicit
Sub TEST6()
    Dim ar, i&, j&, k&, dic As Object
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    With [A1].CurrentRegion
        ar = .Value
        .Font.Color = 0
        For i = 1 To UBound(ar)
            dic.RemoveAll
            For j = 1 To Len(ar(i, 1))
                dic(Mid(ar(i, 1), j, 1)) = Empty
            Next j
            For j = 2 To UBound(ar, 2)
                With .Cells(i, j)
                    For k = 1 To Len(.Value)
                        If dic.exists(Mid(.Value, k, 1)) Then
                           .Characters(k, 1).Font.Color = vbRed
                        End If
                    Next k
                End With
            Next j
        Next i
    End With
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

quqiyuan

参与一下，仅供参考。。

gwjkkkkk

。。。。。。。。

quqiyuan

代码如下。。。
Sub test()
    Set d = CreateObject("scripting.dictionary")
    With Sheet1
        .UsedRange.Font.ColorIndex = 0
        r = .UsedRange.Rows.Count
        For i = 1 To r
            s = .Cells(i, 1)
            If Len(s) <> 0 Then
                For x = 1 To Len(s)
                    d(Mid(s, x, 1)) = ""
                Next
            End If
            For j = 2 To .UsedRange.Columns.Count
                 s = .Cells(i, j)
                If Len(s) <> 0 Then
                    For x = 1 To Len(s)
                        If d.exists(Mid(s, x, 1)) Then .Cells(i, j).Characters(j, 1).Font.Color = vbRed
                    Next
                End If
            Next
        Next
    End With
    Set d = Nothing
    Beep
End Sub

扇扇扇

参与一下，，

扇扇扇

，，，，，，

quqiyuan

刚才急急忙忙有事出去，没有核对，现在看到有错误，现更正。。。

quqiyuan

代码如下。。。
Sub test()
    Set d = CreateObject("scripting.dictionary")
    With Sheet1
        .UsedRange.Font.ColorIndex = 0
        r = .UsedRange.Rows.Count
        For i = 1 To r
            s = .Cells(i, 1)
            If Len(s) <> 0 Then
                For x = 1 To Len(s)
                    d(Mid(s, x, 1)) = ""
                Next
            End If
            For j = 2 To .UsedRange.Columns.Count
                 s = .Cells(i, j)
                If Len(s) <> 0 Then
                    For x = 1 To Len(s)
                        If d.exists(Mid(s, x, 1)) Then .Cells(i, j).Characters(x, 1).Font.Color = vbRed
                    Next
                End If
            Next
            d.RemoveAll
        Next
    End With
    Set d = Nothing
    Beep
End Sub