[已解决]请教统计红色数字的个数

yizhih

请教统计红色数字的个数，谢谢！
统计红色数字的个数.rar (4.69 KB, 下载次数: 21)

2013-2-6 11:07 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

suye1010

2013-2-7 16:15

1. 
   
2. Sub STR1()
   
3. Dim rng As Range, i As Integer, m As Integer
   
4. For i = 1 To 23
   
5.     m = 0
   
6.     If Application.WorksheetFunction.Sum(Range("B5:G5").Offset(i)) Then
   
7.         For Each rng In Range("B5:G5").Offset(i)
   
8.             If rng.Font.Color = 255 Then m = m + 1
   
9.         Next
   
10.         Range("H5").Offset(i) = m
    
11.     End If
    
12. Next i
    
13. End Sub
    
14. Sub STR2()
    
15. Dim rng As Range, AC, i As Integer, m As Integer, n As Integer
    
16. For Each rng In Range("M6:M23")
    
17.     If rng <> "" Then
    
18.         m = 0
    
19.         n = 1
    
20.         For Each AC In Split(rng)
    
21.            If AC <> "" And rng.Characters(n, Len(AC)).Font.Color = 255 Then m = m + 1
    
22.            n = n + Len(AC) + 1
    
23.         Next
    
24.         rng.Offset(0, 3) = m
    
25.     End If
    
26. Next
    
27. End Sub
    

复制代码

跳转到最佳答案楼层

无聊的疯子

第一种使用技巧就可以了

无聊的疯子

第二种代码

1. 
   
2. Sub cc()
   
3. Dim X As Integer, S As String, JX As Integer, M As String
   
4.   For X = 1 To Len(Range("B8").Value)
   
5.     S = Mid(Range("B8").Value, X, 1)
   
6.     If S <> " " And Range("B8").Characters(X, 1).Font.Color = 255 Then
   
7.       M = M & S
   
8.     Else
   
9.      If M <> "" Then
   
10.       JX = JX + 1
    
11.       M = ""
    
12.      End If
    
13.     End If
    
14.   Next
    
15.   MsgBox "有 " & JX & " 个红色数字"
    
16. End Sub
    

复制代码

yizhih

无聊的疯子 发表于 2013-2-6 11:41
第二种代码

谢谢您，是我没讲清楚，我是想要多行统计，且不要弹出框形式。请您再帮助一下。传上修改的附件。
统计红色数字的个数.rar (5.21 KB, 下载次数: 12)

2013-2-6 23:58 上传

点击文件名下载附件

suye1010

1. 
   
2. Sub STR1()
   
3. Dim rng As Range, i As Integer, m As Integer
   
4. For i = 1 To 23
   
5.     m = 0
   
6.     If Application.WorksheetFunction.Sum(Range("B5:G5").Offset(i)) Then
   
7.         For Each rng In Range("B5:G5").Offset(i)
   
8.             If rng.Font.Color = 255 Then m = m + 1
   
9.         Next
   
10.         Range("H5").Offset(i) = m
    
11.     End If
    
12. Next i
    
13. End Sub
    
14. Sub STR2()
    
15. Dim rng As Range, AC, i As Integer, m As Integer, n As Integer
    
16. For Each rng In Range("M6:M23")
    
17.     If rng <> "" Then
    
18.         m = 0
    
19.         n = 1
    
20.         For Each AC In Split(rng)
    
21.            If AC <> "" And rng.Characters(n, Len(AC)).Font.Color = 255 Then m = m + 1
    
22.            n = n + Len(AC) + 1
    
23.         Next
    
24.         rng.Offset(0, 3) = m
    
25.     End If
    
26. Next
    
27. End Sub
    

复制代码

yizhih

suye1010 发表于 2013-2-7 16:15

非常感谢您的帮助，非常好。