求段判断相同内容的代码，谢谢

760636412

详细如附件： 判断相同内容.zip (11.08 KB, 下载次数: 4)

2024-8-17 13:06 上传

点击文件名下载附件

求段判断相同内容标颜色的代码，谢谢指导。

liulang0808

liulang0808

用的是表格时间，供参考。。。。。。

Qs18

Sub qs()
Dim arr, i, dic As Object
Set dic = CreateObject("scripting.dictionary")
arr = Sheet2.Range("a1").CurrentRegion.Value
For i = 2 To UBound(arr)
    s = arr(i, 2)
    If s <> Empty Then
        If Not dic.exists(s) Then
            dic(s) = arr(i, 6)
        Else
            dic(s) = dic(s) & " " & arr(i, 6)
        End If
    End If
Next
With Sheet1
    ss = .Range("c9").Value
    .Range("c9").Interior.Pattern = xlNone
    rw = .Cells(Rows.Count, "e").End(xlUp).Row
    If dic.exists(s) Then
    .Range("c9").Interior.Color = 5296274
    t = dic(s)
    End If
    For i = 12 To rw
        .Range("e" & i).Interior.Pattern = xlNone
        If InStr(t, .Range("e" & i).Value) Then
            .Range("e" & i).Interior.Color = 5296274
        End If
    Next
End With
End Sub

Qs18

试试..........

Qs18

试试............

一招秒杀

为了这么简单的要求 去写一大堆极不直观的VBA代码 不值得，一个简单的条件格式就搞定了，或者你还可以做得更简单一些。