标记单元格里符合要求的数据

cjb3030

如图，求助大侠。先谢谢哈！

liulang0808

1. Sub Macro1()
   
2.     Application.ScreenUpdating = False
   
3.     Set d = CreateObject("scripting.dictionary")
   
4.     For j = 1 To Cells(Rows.Count, 1).End(3).Row
   
5.         arr = Split(Cells(j, 1), " ")
   
6.         d.RemoveAll
   
7.         For i = 0 To UBound(arr)
   
8.             If Val(arr(i)) > 300 Then
   
9.                 d(arr(i)) = 1 + d(arr(i))
   
10.             End If
    
11.         Next i
    
12.         If d.Count > 0 Then
    
13.             For i = 0 To d.Count - 1
    
14.                 st = 1
    
15.                 For l = 1 To d.items()(i)
    
16.                     If InStr(st, Cells(j, 1), d.keys()(i)) > 0 Then
    
17.                         With Cells(j, 1).Characters(Start:=InStr(st, Cells(j, 1), d.keys()(i)), Length:=3).Font
    
18.                             .ColorIndex = 3
    
19.                         End With
    
20.                         st = InStr(st, Cells(j, 1), d.keys()(i)) + 1
    
21.                     End If
    
22.                 Next l
    
23.             Next i
    
24.         End If
    
25.     Next j
    
26.     Application.ScreenUpdating = True
    
27. End Sub
    

复制代码

liulang0808

附件内容供参考。。。。。。

microyip

1. Sub 标记大于300()
   
2.     Dim vData As Variant, nRow As Integer
   
3.     Dim vNum As Variant, nI As Integer, nBit As Integer
   
4.    
   
5.     Application.ScreenUpdating = False
   
6.     With [A1].CurrentRegion
   
7.         vData = .Value
   
8.         .Font.ColorIndex = xlAutomatic
   
9.     End With
   
10.    
    
11.     For nRow = 1 To UBound(vData)
    
12.         vNum = Split(vData(nRow, 1), " ")
    
13.         nBit = 1
    
14.         With Cells(nRow, 1)
    
15.             For nI = 0 To UBound(vNum)
    
16.                 If Val(vNum(nI)) > 300 Then
    
17.                     .Characters(Start:=nBit, Length:=Len(vNum(nI))).Font.Color = -16776961
    
18.                 End If
    
19.                 nBit = nBit + Len(vNum(nI)) + 1
    
20.             Next
    
21.         End With
    
22.     Next
    
23.     Application.ScreenUpdating = True
    
24. End Sub

复制代码

microyip

附上附件以供参考

cjb3030

liulang0808 发表于 2018-8-24 08:55
附件内容供参考。。。。。。

谢谢，谢谢。崇拜得不得了。

cjb3030

microyip 发表于 2018-8-24 09:08
附上附件以供参考

谢谢您。2楼大师的代码管了整A列，您的要稍微改一改，同样优秀。谢谢哈。

cjb3030

microyip 发表于 2018-8-24 09:08
附上附件以供参考

我又测试了，a列如果是连续的，您的也可以。