[已解决]请教老师一个关于填充颜色的问题

yslvictor

今有一问题就是：颜色填充能否提高一下运行的速度，请老师赐教。
含义：从G6：G60005中仅对文本字数字体加粗并填充颜色，5个字符则背景蓝色字体白色;4个字符则背景绿色字体黑;3个字符及以下则背景红色字体白色。
原代码：
Sub 填充颜色()
   t = Timer
   Range("G6").CurrentRegion.ClearFormats
   For Each rng In Range("G6" & ":G" & Range("G65536").End(xlUp).Row)
       If VarType(rng) = vbString Then
           With rng
              .Font.Bold = True
               If Len(rng) = 5 Then
                   .Font.Color = RGB(255, 255, 255)
                   .Interior.Color = RGB(0, 0, 255)
               Else
                   If Len(rng) = 4 Then
                       .Font.Color = RGB(0, 0, 0)
                       .Interior.Color = RGB(0, 255, 0)
                   Else
                       .Font.Color = RGB(255, 255, 255)
                       .Interior.Color = RGB(255, 0, 0)
                   End If
               End If
           End With
       End If
   Next
   Range("H1") = "耗时" & Timer - t & "秒"
End Sub
批量填充颜色.rar (340.97 KB, 下载次数: 11)

2016-11-29 16:43 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

grf1973

2016-11-30 15:48

不用条件格式，代码比较烦琐一点。运行4.3秒。

1. Sub 填充颜色1()
   
2.    Dim BldRng$, Rng5$, Rng4$, Rng3$
   
3.    t = Timer
   
4.    Range("G6").CurrentRegion.ClearFormats
   
5.    arr = Range("G1:g" & Cells(Rows.Count, 7).End(3).Row)
   
6.    For i = 1 To UBound(arr)
   
7.         x = arr(i, 1): xstr = "," & "G" & i
   
8.         If VarType(x) = vbString Then
   
9.             If Len(BldRng) + Len(xstr) <= 256 Then   'Range(x)中，x的长度不能超过255
   
10.                 BldRng = BldRng & xstr
    
11.                 If Len(x) = 5 Then
    
12.                     Rng5 = Rng5 & xstr
    
13.                 ElseIf Len(x) = 4 Then
    
14.                     Rng4 = Rng4 & xstr
    
15.                 Else
    
16.                     Rng3 = Rng3 & xstr
    
17.                 End If
    
18.             Else
    
19.                 BldRng = Mid(BldRng, 2)
    
20.                 Range(BldRng).Font.Bold = True
    
21.                
    
22.                 Rng5 = Mid(Rng5, 2)
    
23.                 If Len(Rng5) Then
    
24.                      Range(Rng5).Font.Color = RGB(255, 255, 255)
    
25.                      Range(Rng5).Interior.Color = RGB(0, 0, 255)
    
26.                 End If
    
27.                                 
    
28.                 Rng4 = Mid(Rng4, 2)
    
29.                 If Len(Rng4) Then
    
30.                      Range(Rng4).Font.Color = RGB(0, 0, 0)
    
31.                      Range(Rng4).Interior.Color = RGB(0, 255, 0)
    
32.                 End If
    
33.                                 
    
34.                 Rng3 = Mid(Rng3, 2)
    
35.                 If Len(Rng3) Then
    
36.                      Range(Rng3).Font.Color = RGB(255, 255, 255)
    
37.                      Range(Rng3).Interior.Color = RGB(255, 0, 0)
    
38.                 End If
    
39.                
    
40.                 BldRng = xstr
    
41.                 Rng5 = xstr
    
42.                 Rng4 = xstr
    
43.                 Rng3 = xstr
    
44.             End If
    
45.         End If
    
46.     Next
    
47.    
    
48.     BldRng = Mid(BldRng, 2)
    
49.     If Len(BldRng) Then Range(BldRng).Font.Bold = True
    
50.    
    
51.     Rng5 = Mid(Rng5, 2)
    
52.     If Len(Rng5) Then
    
53.          Range(Rng5).Font.Color = RGB(255, 255, 255)
    
54.          Range(Rng5).Interior.Color = RGB(0, 0, 255)
    
55.     End If
    
56.                     
    
57.     Rng4 = Mid(Rng4, 2)
    
58.     If Len(Rng4) Then
    
59.          Range(Rng4).Font.Color = RGB(0, 0, 0)
    
60.          Range(Rng4).Interior.Color = RGB(0, 255, 0)
    
61.     End If
    
62.                     
    
63.     Rng3 = Mid(Rng3, 2)
    
64.     If Len(Rng3) Then
    
65.          Range(Rng3).Font.Color = RGB(255, 255, 255)
    
66.          Range(Rng3).Interior.Color = RGB(255, 0, 0)
    
67.     End If
    
68.    
    
69.    Range("H1") = "耗时" & Timer - t & "秒"
    
70. End Sub

复制代码

跳转到最佳答案楼层

砂海

不一个单元格一个单元格操作
用 字符串 批量操作
dim x$
.
.
for i...
if ?? then x=x & "A" & i & ","

next i

===========
i 的长度不能超过255

单元格循环 也不要用 , 用数组循环

爱疯

Sub test()
    Dim rng As Range
    Dim fc1 As FormatCondition
    Dim fc2 As FormatCondition
    Dim fc3 As FormatCondition
    Dim fc4 As FormatCondition


    Cells.FormatConditions.Delete
    Sheets(1).Activate
    Set rng = Range([G6], [G65536].End(xlUp))


    Set fc1 = rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=istext(g6)")
    fc1.Font.Bold = True
    fc1.StopIfTrue = False    'false表示在满足当前条件时，不停止计算（其它的条件格式）。


    Set fc2 = rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=and(istext(g6),len(g6)=5)")
    fc2.Font.Color = RGB(255, 255, 255)    '白
    fc2.Interior.Color = RGB(0, 0, 255)    '蓝


    Set fc3 = rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=and(istext(g6),len(g6)=4)")
'    fc3.Font.Color = RGB(0, 0, 0)    '黑
    fc3.Interior.Color = RGB(0, 255, 0)    '绿


    Set fc4 = rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=and(istext(g6),or(len(g6)<4,len(g6)>5))")
    fc4.Font.Color = RGB(255, 255, 255)    '白
    fc4.Interior.Color = RGB(255, 0, 0)    '红

End Sub
批量填充颜色2.rar (344.97 KB, 下载次数: 3)

2016-11-30 14:56 上传

点击文件名下载附件



1）用条件格式能快些。
2）其实，手动添加条件格式即可。这里只不过来用代码来完成这个操作而已。
3）03最多允许3个条件格式，这题有4个，03也没报错？奇怪。
4）不知能否改简单点。

grf1973

不用条件格式，代码比较烦琐一点。运行4.3秒。

1. Sub 填充颜色1()
   
2.    Dim BldRng$, Rng5$, Rng4$, Rng3$
   
3.    t = Timer
   
4.    Range("G6").CurrentRegion.ClearFormats
   
5.    arr = Range("G1:g" & Cells(Rows.Count, 7).End(3).Row)
   
6.    For i = 1 To UBound(arr)
   
7.         x = arr(i, 1): xstr = "," & "G" & i
   
8.         If VarType(x) = vbString Then
   
9.             If Len(BldRng) + Len(xstr) <= 256 Then   'Range(x)中，x的长度不能超过255
   
10.                 BldRng = BldRng & xstr
    
11.                 If Len(x) = 5 Then
    
12.                     Rng5 = Rng5 & xstr
    
13.                 ElseIf Len(x) = 4 Then
    
14.                     Rng4 = Rng4 & xstr
    
15.                 Else
    
16.                     Rng3 = Rng3 & xstr
    
17.                 End If
    
18.             Else
    
19.                 BldRng = Mid(BldRng, 2)
    
20.                 Range(BldRng).Font.Bold = True
    
21.                
    
22.                 Rng5 = Mid(Rng5, 2)
    
23.                 If Len(Rng5) Then
    
24.                      Range(Rng5).Font.Color = RGB(255, 255, 255)
    
25.                      Range(Rng5).Interior.Color = RGB(0, 0, 255)
    
26.                 End If
    
27.                                 
    
28.                 Rng4 = Mid(Rng4, 2)
    
29.                 If Len(Rng4) Then
    
30.                      Range(Rng4).Font.Color = RGB(0, 0, 0)
    
31.                      Range(Rng4).Interior.Color = RGB(0, 255, 0)
    
32.                 End If
    
33.                                 
    
34.                 Rng3 = Mid(Rng3, 2)
    
35.                 If Len(Rng3) Then
    
36.                      Range(Rng3).Font.Color = RGB(255, 255, 255)
    
37.                      Range(Rng3).Interior.Color = RGB(255, 0, 0)
    
38.                 End If
    
39.                
    
40.                 BldRng = xstr
    
41.                 Rng5 = xstr
    
42.                 Rng4 = xstr
    
43.                 Rng3 = xstr
    
44.             End If
    
45.         End If
    
46.     Next
    
47.    
    
48.     BldRng = Mid(BldRng, 2)
    
49.     If Len(BldRng) Then Range(BldRng).Font.Bold = True
    
50.    
    
51.     Rng5 = Mid(Rng5, 2)
    
52.     If Len(Rng5) Then
    
53.          Range(Rng5).Font.Color = RGB(255, 255, 255)
    
54.          Range(Rng5).Interior.Color = RGB(0, 0, 255)
    
55.     End If
    
56.                     
    
57.     Rng4 = Mid(Rng4, 2)
    
58.     If Len(Rng4) Then
    
59.          Range(Rng4).Font.Color = RGB(0, 0, 0)
    
60.          Range(Rng4).Interior.Color = RGB(0, 255, 0)
    
61.     End If
    
62.                     
    
63.     Rng3 = Mid(Rng3, 2)
    
64.     If Len(Rng3) Then
    
65.          Range(Rng3).Font.Color = RGB(255, 255, 255)
    
66.          Range(Rng3).Interior.Color = RGB(255, 0, 0)
    
67.     End If
    
68.    
    
69.    Range("H1") = "耗时" & Timer - t & "秒"
    
70. End Sub

复制代码

grf1973

当然，中间一段填色的可以用子程序写。

grf1973

请看附件。

laoau138

grf1973 发表于 2016-11-30 15:51
请看附件。

VBA用自定义函数汇总前N大值  用两种方法



http://www.excelpx.com/thread-426057-1-1.html

yslvictor

爱疯 发表于 2016-11-30 15:03
Sub test()
    Dim rng As Range
    Dim fc1 As FormatCondition

爱疯老师的运行时怎么出现错误，是我的计算机的事吗？
是运行到这里出的错
fc1.StopIfTrue = False    'false表示在满足当前条件时，不停止计算（其它的条件格式）。

麻烦看看在你的电脑是否正常？

爱疯

yslvictor 发表于 2016-11-30 21:08
爱疯老师的运行时怎么出现错误，是我的计算机的事吗？
是运行到这里出的错
fc1.StopIfTrue = False     ...

Sub test()
    Dim rng As Range
    Dim fc1 As FormatCondition
    Dim fc2 As FormatCondition
    Dim fc3 As FormatCondition
    Dim fc4 As FormatCondition

    Sheets(1).Activate
    Cells.FormatConditions.Delete
    [g6].Select
    Set rng = Range([g6], [G65536].End(xlUp))

    '    Set fc1 = rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=istext(g6)")
    '    fc1.Font.Bold = True
    '    fc1.StopIfTrue = False    'false表示在满足当前条件时，不停止计算（其它的条件格式）。

    Set fc2 = rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=and(istext(g6),len(g6)=5)")
    fc2.Font.Color = RGB(255, 255, 255)    '白
    fc2.Interior.Color = RGB(0, 0, 255)    '蓝

    Set fc3 = rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=and(istext(g6),len(g6)=4)")
    fc3.Interior.Color = RGB(0, 255, 0)    '绿

    Set fc4 = rng.FormatConditions.Add(Type:=xlExpression, Formula1:="=and(istext(g6),or(len(g6)<4,len(g6)>5))")
    fc4.Font.Color = RGB(255, 255, 255)    '白
    fc4.Interior.Color = RGB(255, 0, 0)    '红

End Sub



03只能添加3个条件格式，所以取消第1个条件（如果是文本，就字体加粗）。
这样可以吗

yslvictor

谢谢爱疯老师和grf1973 老师，grf1973 老师的代码运行后不存在条件格式，觉得更好一点。