请各位大神指导小女子，如何在相同的单元格标记同一种颜色，不同值不同颜色

caiweihong · 发表于 2017-7-30 05:31

本帖最后由 caiweihong 于 2017-7-30 22:50 编辑

向各位求助一下，我对VBA一窍不通，在论坛找到一个符合我要求的代码，可是不知道如何修改，麻烦各位帮我看一下，如何修改比较好

我需要在E4：E143范围内找出多种重复值，用不同颜色区分，相同值的单元格标记同一种颜色，没有相同就不用标记颜色

--------------------------------我是美丽的分割线--------------------------------------------
按照7楼“”蓝桥玄霜“”给的代码，复制到Sheet2中，提示子过程或函数未定义
本人对这个一点也不懂，请问大神们帮帮看一下，要如何修改？感谢

Sub Macro1()
Dim arr, d As Object, k, t, i&, n%, aa, j&
Columns("f:f").Interior.ColorIndex = xlNone
Set d = CreateObject("scripting.dictionary")
arr = Range("e4:e" & Range("e65536").End(xlUp).Row)
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) & i & ","
Next i
k = d.keys: t = d.items: n = 1
For i = 0 To UBound(k)
t(i) = Left(t(i), Len(t(i)) - 1)
If InStr(t(i), ",") Then
n = n + 1
aa = Split(t(i), ",")
For j = 0 To UBound(aa)
Cella(aa(j) + 3, 6).Interior.ColorIndex = n
Next
End If
Next
End Sub

复制代码

点击运行后提示子过程或函数未定义

jiangxiaoyun · 发表于 2017-7-30 08:30

先提取重复值，字典
根据重复值遍历源数据，添加背景颜色。

jiangxiaoyun · 发表于 2017-7-30 08:47

Sub CAT()
Dim arr, i&, s
Set d = CreateObject("scripting.dictionary")
Range("e4", [e1024786].End(3)).Interior.ColorIndex = xlNone
arr = Range("e4", [e1024786].End(3))
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
Next
s = d.keys
For i = 0 To UBound(s)
If d(s(i)) > 1 Then
For j = 1 To UBound(arr)
If arr(j, 1) = s(i) Then
k = k + 1
Cells(j + 3, 5).Interior.ColorIndex = i + 3 Mod 56
If k = d(s(i)) Then Exit For
End If
Next
k = 0
End If
Next
End Sub

复制代码

jiangxiaoyun · 发表于 2017-7-30 08:57

Sub CAT()
Dim arr, i&, s, k&, ss
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Range("e4", [e1024786].End(3)).Interior.ColorIndex = xlNone
arr = Range("e4", [e1024786].End(3))
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
d1(arr(i, 1)) = d1(arr(i, 1)) & "," & (i + 3)
Next
s = d.keys
For i = 0 To UBound(s)
If d(s(i)) > 1 Then
ss = Split(d1(s(i)), ",")
For j = 1 To UBound(ss)
Cells(ss(j), 5).Interior.ColorIndex = k + 3 Mod 56
Next
k = k + 1
End If
Next
End Sub

复制代码

审核>>>>>>>>>>>>

jiangxiaoyun · 发表于 2017-7-30 10:15

Sub CAT()
Dim arr, i&, s, k&, ss
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Range("e4", [e1024786].End(3)).Interior.ColorIndex = xlNone
arr = Range("e4", [e1024786].End(3))
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
d1(arr(i, 1)) = d1(arr(i, 1)) & "," & (i + 3)
Next
s = d.keys
For i = 0 To UBound(s)
If d(s(i)) > 1 Then
ss = Split(d1(s(i)), ",")
For j = 1 To UBound(ss)
Cells(ss(j), 5).Interior.ColorIndex = k + 3 Mod 56
Next
k = k + 1
End If
Next
End Sub

复制代码

继续审核啊>>>>>>>>>>>

jiangxiaoyun · 发表于 2017-7-30 10:17

Sub CAT()
Dim arr, i&, s, k&, ss
Set d = CreateObject("scripting.dictionary")
Set d1 = CreateObject("scripting.dictionary")
Range("e4", [e1024786].End(3)).Interior.ColorIndex = xlNone
arr = Range("e4", [e1024786].End(3))
For i = 1 To UBound(arr)
d(arr(i, 1)) = d(arr(i, 1)) + 1
d1(arr(i, 1)) = d1(arr(i, 1)) & "," & (i + 3)
Next
s = d.keys
For i = 0 To UBound(s)
If d(s(i)) > 1 Then
ss = Split(d1(s(i)), ",")
For j = 1 To UBound(ss)
Cells(ss(j), 5).Interior.ColorIndex = k + 3 Mod 56
Next
k = k + 1
End If
Next
End Sub

复制代码

来来来，继续审核》》》》》》》》》》》》

蓝桥玄霜 · 发表于 2017-7-30 10:23

jiangxiaoyun · 发表于 2017-7-30 10:31

来来来，继续审核，继续审核啊！！！

jiangxiaoyun · 发表于 2017-7-30 10:32

tm我早上发的两个代码发了空气啊，这两个代码有违规吗？

caiweihong · 发表于 2017-7-30 14:11

jiangxiaoyun 发表于 2017-7-30 10:17
来来来，继续审核》》》》》》》》》》》》

谢谢你的用心回答，麻烦你了

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

[求助] 请各位大神指导小女子，如何在相同的单元格标记同一种颜色，不同值不同颜色

评分