[已解决]满足条件的单元格填充颜色

left369

满足条件的单元格填充颜色  

最佳答案

月排行榜 / 总排行榜

dsmch

2014-12-6 22:50

1. Sub Macro1()
   
2. Dim arr, d, i%, j&, h%, l&
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For i = 4 To 6
   
6.     For j = 2 To 256 - i + 1
   
7.         arr = Cells(22, j).Resize(2, 4)
   
8.         For h = 1 To UBound(arr)
   
9.             For l = 1 To UBound(arr, 2)
   
10.                 d(arr(h, l)) = ""
    
11.             Next
    
12.         Next
    
13.         If d.Count = i Then Cells(22, j).Resize(2, 4).Interior.ColorIndex = i
    
14.         d.RemoveAll
    
15.     Next
    
16.     [a22:iv23].Copy Cells(22 + (i - 3) * 3, 1)
    
17.     [a22:iv23].Interior.ColorIndex = xlNone
    
18. Next
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码

跳转到最佳答案楼层

left369

顶一下

爱疯

看不懂说明

left369

爱疯 发表于 2014-12-6 21:21
看不懂说明

也就是连续列中，不同的个数不超过5个的，填充颜色。

爱疯

黄色的19007 ，不是连续两个0吗，怎么也要填充？

left369

爱疯 发表于 2014-12-6 21:26
黄色的19007 ，不是连续两个0吗，怎么也要填充？

比如黄色区域连续5列，但只有4个不同的数字，所以填充颜色。

爱疯

不明白你的解释
你手动从B列到AH列填好，看看？

left369

爱疯 发表于 2014-12-6 21:52
不明白你的解释
你手动从B列到AH列填好，看看？

也就是动态查询到某一区域，满足只有4个或者5个不同的数字，这一区域填充颜色

left369

爱疯 发表于 2014-12-6 21:52
不明白你的解释
你手动从B列到AH列填好，看看？

这个区域是连续的列且必须有4列以上。比如黄色区域有5列(超过4列），且这一区域只有4个不同的数字（0，1，7，9）。则填充颜色。

dsmch

1. Sub Macro1()
   
2. Dim arr, d, i%, j&, h%, l&
   
3. Application.ScreenUpdating = False
   
4. Set d = CreateObject("scripting.dictionary")
   
5. For i = 4 To 6
   
6.     For j = 2 To 256 - i + 1
   
7.         arr = Cells(22, j).Resize(2, 4)
   
8.         For h = 1 To UBound(arr)
   
9.             For l = 1 To UBound(arr, 2)
   
10.                 d(arr(h, l)) = ""
    
11.             Next
    
12.         Next
    
13.         If d.Count = i Then Cells(22, j).Resize(2, 4).Interior.ColorIndex = i
    
14.         d.RemoveAll
    
15.     Next
    
16.     [a22:iv23].Copy Cells(22 + (i - 3) * 3, 1)
    
17.     [a22:iv23].Interior.ColorIndex = xlNone
    
18. Next
    
19. Application.ScreenUpdating = True
    
20. End Sub

复制代码