同个表格内5钟颜色的数字

明白syy

项目	数据1	数据2
1	14/0/1/0/2	18/0/2/0/2		11/0/6/9/27
2	10/10/1/7/1	3/10/0/6/3		16/9/3/2/5
3	1/5/0/0/4	0/5/0/0/2
4	0/1/0/2/9	1/1/0/2/8			能否批量改变表格中数字的颜色和加粗度，使表格上的数字跟斜上面的两行数字一样。
5	0/11/0/1/13	0/4/0/0/6			像这样的数据有100来个，希望大神提供好的方法，谢谢。
6	1/9/0/1/8	1/11/0/1/10
7	2/14/0/11/3	1/12/0/9/7			要求：
8	0/15/0/3/8	0/14/0/1/7			第一个斜杠前的数字需要标红加粗，第二个斜杠前的数字需要标红不加粗，
9	0/9/0/3/5	0/12/0/3/5			第三个斜杠前的数字需要标橙色加粗，第四个斜杠前的数字需要标绿加粗，第四个斜杠后的数字需要标黑色不加粗，
10	2/16/0/8/11	3/18/0/10/6			斜杠全是黑色不加粗。

李兴德

这个不好办吧   

zhjlgaojuan

Sub test()
Dim Source As Range, Rng As Range
Dim arr, y&
Set Source = Sheet1.UsedRange
For Each Rng In Source
    arr = Split(Rng.Value, "/")
    y = 1
    If UBound(arr) = 4 Then
       For i = 0 To UBound(arr)
            With Rng.Characters(Start:=y, Length:=Len(arr(i))).Font
                Select Case i
                   Case 0
                       .ColorIndex = 3
                       .Bold = True
                   Case 1
                       .ColorIndex = 3
                   Case 2
                       .ColorIndex = 45
                       .Bold = True
                   Case 3
                       .ColorIndex = 4
                       .Bold = True
                   Case 4
                       .ColorIndex = 1
                End Select
            End With
            y = y + Len(arr(i)) + 1
        Next
    End If
Next
End Sub

jnsxmt

1. Sub test()
   
2.     Dim ar, br, cr(), rag As Range, m&, n&, k&, q&, p&
   
3.     p = 1: q = 1
   
4.     For Each rag In Range("b2:c11")
   
5.         br = Split(rag, "/")
   
6.             For n = LBound(br) To UBound(br)
   
7.                 k = k + 1
   
8.                 ReDim Preserve cr(1 To k)
   
9.                 cr(k) = Len(br(n))
   
10.             Next
    
11.             With rag.Characters(Start:=p, Length:=cr(q)).Font
    
12.                 .FontStyle = "加粗"
    
13.                 .ColorIndex = 3
    
14.             End With
    
15.             p = p + cr(q) + 1: q = q + 1
    
16.             With rag.Characters(Start:=p, Length:=cr(q)).Font
    
17.                 .ColorIndex = 3
    
18.             End With
    
19.             p = p + cr(q) + 1: q = q + 1
    
20.             With rag.Characters(Start:=p, Length:=cr(q)).Font
    
21.                 .FontStyle = "加粗"
    
22.                 .Color = -16727809
    
23.             End With
    
24.             p = p + cr(q) + 1: q = q + 1
    
25.             With rag.Characters(Start:=p, Length:=cr(q)).Font
    
26.                 .FontStyle = "加粗"
    
27.                 .ColorIndex = 10
    
28.             End With
    
29.             p = 1: q = 1: Erase cr: Erase br: k = 0
    
30.     Next
    
31. End Sub

复制代码

ione_fox

1. 
   
2. Sub test()
   
3. Dim Rng As Range, RG As Range, I&, K&, K1&, J&, ooo
   
4.     Set Rng = Application.InputBox("选择指定区域", "选择框", Type:=8)
   
5.     For Each RG In Rng
   
6.      K = 0: J = 0
   
7.         For I = 1 To Len(RG) + 1
   
8.         K1 = K
   
9.             If Mid(RG & "/", I, 1) = "/" Then
   
10.              K = 0
    
11.             ooo = Mid(RG, I, 1)
    
12.                 K = K + I: J = J + 1
    
13. '                Debug.Print I
    
14. '                Debug.Print Mid(RG, I, 1)
    
15. '                Debug.Print "K=" & K, "K1=" & K1
    
16. '                Stop
    
17.                     If J = 1 Then
    
18.                             RG.Characters(K1 + 1, K - K1 - 1).Font.ColorIndex = 8
    
19.                             RG.Characters(K1 + 1, K - K1 - 1).Font.Bold = True
    
20.                         ElseIf J = 2 Then
    
21.                             RG.Characters(K1 + 1, K - K1 - 1).Font.ColorIndex = 8
    
22.                             RG.Characters(K1 + 1, K - K1 - 1).Font.Bold = True
    
23.                         ElseIf J = 3 Then
    
24.                             RG.Characters(K1 + 1, K - K1 - 1).Font.ColorIndex = 8
    
25.                             RG.Characters(K1 + 1, K - K1 - 1).Font.Bold = True
    
26.                         ElseIf J = 4 Then
    
27.                             RG.Characters(K1 + 1, K - K1 - 1).Font.ColorIndex = 8
    
28.                             RG.Characters(K1 + 1, K - K1 - 1).Font.Bold = True
    
29.                         ElseIf J = 5 Then
    
30.                             RG.Characters(K1 + 1, K - K1 - 1).Font.ColorIndex = 8
    
31.                             RG.Characters(K1 + 1, K - K1 - 1).Font.Bold = True
    
32.                     End If
    
33.                 Else
    
34.                
    
35.             End If
    
36.         Next I
    
37.     Next

复制代码

ione_fox

附件测试颜色自己选择下

ione_fox

正则方法：

1. 
   

复制代码

ione_fox

正则方法

1. Sub test2() '正则方式
   
2. Dim Rng As Range, RG As Range, I&, Matchs, M
   
3.     With CreateObject("vbscript.regexp")
   
4.             .Global = True
   
5.             .Pattern = "[0-9]+"
   
6.             .IgnoreCase = True
   
7.     Set Rng = Application.InputBox("选择指定区域", "选择框", Type:=8)
   
8.     For Each RG In Rng
   
9.     I = 0
   
10.         Set Matchs = .Execute(RG.Value)
    
11.         For Each M In Matchs
    
12.             RG.Characters(I + 1, Len(M)).Font.ColorIndex = 8
    
13.             RG.Characters(I + 1, Len(M)).Font.Bold = True
    
14.             I = I + Len(M) + 1
    
15.         Next
    
16.     Next
    
17.     End With
    
18. End Sub
    

复制代码

02761752696

厉害    路过  学习了   

lsdongjh

1. Sub Test()
   
2.     Dim rgSource As Range, rg As Range
   
3.     Dim arrColors As Variant
   
4.    
   
5.     Set rgSource = Sheet1.Range("C2:C11")
   
6.     arrColors = Array(3, 3, 45, 4, 1)
   
7.    
   
8.     For Each rg In rgSource
   
9.         SetCharColor rg, arrColors
   
10.     Next
    
11. End Sub
    
12. 
    
13. 
    
14. Function SetCharColor(rg As Range, arrColor As Variant)
    
15.     Dim strVal As String, strSplit() As String, strChar As String
    
16.     Dim arrInfo As Variant, lngRow As Long
    
17.     Dim intLen As Integer
    
18.    
    
19.     strVal = rg.Value
    
20.     strChar = "/"
    
21.     strSplit = Split(strVal, strChar)
    
22.     ReDim arrInfo(1 To UBound(strSplit) + 1, 1 To 3)
    
23.    
    
24.     intLen = 1
    
25.     For lngRow = LBound(strSplit) To UBound(strSplit)
    
26.         arrInfo(lngRow + 1, 1) = intLen
    
27.         arrInfo(lngRow + 1, 2) = Len(strSplit(lngRow))
    
28.         arrInfo(lngRow + 1, 3) = arrColor(lngRow)
    
29.         intLen = intLen + Len(strSplit(lngRow)) + Len(strChar)
    
30.     Next
    
31.    
    
32.     For lngRow = LBound(arrInfo) To UBound(arrInfo)
    
33.         rg.Characters(arrInfo(lngRow, 1), arrInfo(lngRow, 2)).Font.ColorIndex = arrInfo(lngRow, 3)
    
34.         If lngRow <> 2 And lngRow <= 4 Then rg.Characters(arrInfo(lngRow, 1), arrInfo(lngRow, 2)).Font.Bold = True
    
35.     Next
    
36. End Function

复制代码