求统计并填充提示代码（已解决）

gwjkkkkk

Option Explicit
Sub TEST()
    Dim ar, i&, j&, k&, dic As Object, vKey
   
    Application.ScreenUpdating = False
    Set dic = CreateObject("Scripting.Dictionary")
   
    For k = 1 To 14
        With Cells(8, (k - 1) * 9 + 2).Resize(, 9).Resize(29993)
            .Interior.ColorIndex = xlNone
            ar = .Value
            For i = 1 To UBound(ar)
                dic.RemoveAll
                For j = 1 To UBound(ar, 2)
                    If ar(i, j) <> "" Then
                        dic(ar(i, j)) = dic(ar(i, j)) + 1
                    End If
                Next j
                For Each vKey In dic.keys
                    If dic(vKey) > 1 Then
                         For j = 1 To UBound(ar, 2)
                             If ar(i, j) = vKey Then
                                 .Cells(i, j).Interior.Color = vbRed
                             End If
                         Next j
                    Else
                        For j = 1 To UBound(ar, 2)
                             If ar(i, j) = vKey Then
                                 .Cells(i, j).Interior.Color = vbBlue
                             End If
                         Next j
                    End If
                Next
            Next i
        End With
    Next k
   
    Set dic = Nothing
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

jx928867128 发表于 2023-2-28 20:13
老师好，能再帮我一个忙吗，我还需要统计在同一区域内名字一共只出现过一次的用蓝色进行填充标注。

请楼主参考。。。

jx928867128

gwjkkkkk 发表于 2023-2-28 20:28
请楼主参考。。。

谢谢大神的帮忙，结果好象不对，同一区域内同一行中出现2次的也标了色，我是要对大于2次的进行标色啊

gwjkkkkk

jx928867128 发表于 2023-2-28 20:38
谢谢大神的帮忙，结果好象不对，同一区域内同一行中出现2次的也标了色，我是要对大于2次的进行标色啊

也就是忽略二次，一次标蓝，大于二次标红，对吗？请参考附件。。。。

jx928867128

gwjkkkkk 发表于 2023-2-28 20:57
也就是忽略二次，一次标蓝，大于二次标红，对吗？请参考附件。。。。

万分感谢老师的帮忙，你再次帮我写的代码中同一区域内同一行中名字出现的次数大于2的进行标色是完全正确，但同一区域内名字一共出现的次数等于1次的标注不对（当前的程序是把同一区域内同一行中名字出现的次数等于1的标注出来了），

gwjkkkkk

jx928867128 发表于 2023-2-28 22:14
万分感谢老师的帮忙，你再次帮我写的代码中同一区域内同一行中名字出现的次数大于2的进行标色是完全正确 ...

请楼主参考附件。。。

jx928867128

gwjkkkkk 发表于 2023-2-28 22:56
请楼主参考附件。。。

太感谢您了，祝您生活愉快，献花受限了，等不限制再给您献花哈

jx928867128

0000.zip (45.24 KB, 下载次数: 2)

2023-3-1 11:04 上传

点击文件名下载附件

gwjkkkkk 发表于 2023-2-28 22:56
请楼主参考附件。。。

老师好，在平时工作时还需这个功能，不知您方便抽空帮我下吗

gwjkkkkk

jx928867128 发表于 2023-3-1 08:43
老师好，在平时工作时还需这个功能，不知您方便抽空帮我下吗

这样的怎么标？

jx928867128

gwjkkkkk 发表于 2023-3-1 19:45
这样的怎么标？

谢谢老师的再次回复，这样的标黄色