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

jx928867128 · 发表于 2023-2-28 12:20

本帖最后由 jx928867128 于 2023-3-19 18:05 编辑

求.rar (32.4 KB, 下载次数: 10)

jx928867128 · 发表于 2023-2-28 14:42

请路过的帮忙看下

哒哒哒是的撒多 · 发表于 2023-2-28 16:32

0000.zip (65.41 KB, 下载次数: 4)

jx928867128 · 发表于 2023-2-28 17:18

哒哒哒是的撒多发表于 2023-2-28 16:32

谢谢您的出手帮忙，我用实际数据测试了下，统计与标注的结果不正确

哒哒哒是的撒多 · 发表于 2023-2-28 17:25

jx928867128 发表于 2023-2-28 17:18
谢谢您的出手帮忙，我用实际数据测试了下，统计与标注的结果不正确

哪里不正确呀，我试着没问题啊

jx928867128 · 发表于 2023-2-28 17:37

哒哒哒是的撒多发表于 2023-2-28 17:25
哪里不正确呀，我试着没问题啊

有错误标注的附件.rar (42.97 KB, 下载次数: 6)

哒哒哒是的撒多 · 发表于 2023-2-28 19:30

本帖最后由哒哒哒是的撒多于 2023-2-28 19:46 编辑

改了下00000000000000000

jx928867128 · 发表于 2023-2-28 19:53

本帖最后由 jx928867128 于 2023-2-28 20:00 编辑

哒哒哒是的撒多发表于 2023-2-28 19:30
改了下00000000000000000

不好意思，是我填写错了位置

哒哒哒是的撒多 · 发表于 2023-2-28 20:00

jx928867128 发表于 2023-2-28 19:53
万分感谢，还是有点小问题

Sub a()
Set d = CreateObject("scripting.dictionary")
q = 2
x = 2
For s = 1 To 15
If s > 1 Then q = q + 9 ':x=x+

arr = Sheet1.Range(Cells(7, q), Cells(300, q + 8))       '1
For i = 1 To UBound(arr)
For j = 1 To UBound(arr, 2)
      If arr(i, j) <> "" Then d(arr(i, j)) = d(arr(i, j)) + 1
Next
t = d.keys
      For n = 0 To UBound(t)
         If d(t(n)) > 2 Then
            For Each m In Sheet1.Range(Cells(i + 6, q), Cells(i + 6, q + 8)) '2
                  If m <> "" And m.Value = t(n) Then m.Interior.Color = 255

            Next
         End If

      Next

   d.RemoveAll
Next

Next
End Sub

jx928867128 · 发表于 2023-2-28 20:13

哒哒哒是的撒多发表于 2023-2-28 19:30
改了下00000000000000000

老师好，能再帮我一个忙吗，我还需要统计在同一区域内名字一共只出现过一次的用蓝色进行填充标注。

		自动登录	找回密码
密码			免费注册

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

评分

改了下

评分