[已解决]包含则填充红色

天上的云pc

包含则填充红色

最佳答案

月排行榜 / 总排行榜

dsmch

2016-7-23 18:42

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, d, i&, j%, c As Range
   
4. [g16:at25].Interior.ColorIndex = xlNone
   
5. For Each c In [g16:at25]
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     arr = c.Offset(-12, -5).Resize(11, 4)
   
8.     For i = UBound(arr) To 1 Step -1
   
9.         For j = UBound(arr, 2) To 1 Step -1
   
10.             d(arr(i, j)) = ""
    
11.             If d.Count > 6 Then GoTo line100
    
12.         Next
    
13.     Next
    
14. line100:
    
15.     If d.exists(c.Value) Then c.Interior.ColorIndex = 3
    
16. Next
    
17. End Sub

复制代码

跳转到最佳答案楼层

yorkchenshunan

请确认你附件的内容跟你的描述是否相符。

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, d, i&, j%, c As Range
   
4. Set d = CreateObject("scripting.dictionary")
   
5. Set c = Application.InputBox("请用鼠标选中数据区域一个单元格", Type:=8)
   
6. arr = c(1).Offset(-12, -5).Resize(11, 4)
   
7. For i = UBound(arr) To 1 Step -1
   
8.     For j = UBound(arr, 2) To 1 Step -1
   
9.         d(arr(i, j)) = ""
   
10.         If d.Count > 6 Then GoTo line100
    
11.     Next
    
12. Next
    
13. line100:
    
14. If d.exists(c(1).Value) Then c(1).Interior.ColorIndex = 3
    
15. End Sub

复制代码

dsmch

1. Sub Macro1()
   
2. On Error Resume Next
   
3. Dim arr, d, i&, j%, c As Range
   
4. [g16:at25].Interior.ColorIndex = xlNone
   
5. For Each c In [g16:at25]
   
6.     Set d = CreateObject("scripting.dictionary")
   
7.     arr = c.Offset(-12, -5).Resize(11, 4)
   
8.     For i = UBound(arr) To 1 Step -1
   
9.         For j = UBound(arr, 2) To 1 Step -1
   
10.             d(arr(i, j)) = ""
    
11.             If d.Count > 6 Then GoTo line100
    
12.         Next
    
13.     Next
    
14. line100:
    
15.     If d.exists(c.Value) Then c.Interior.ColorIndex = 3
    
16. Next
    
17. End Sub

复制代码