[已解决]请求高手帮忙写2个VBA代码，实现自动添加字体颜色

夏之恋之夏

1.rar (33.71 KB, 下载次数: 16)

2011-11-19 14:58 上传

点击文件名下载附件

请高手帮忙做2个VBA的代码按钮，1个按钮要求实现自动把G列至L列的五行加上字体颜色（5种颜色）（见N至R列），另一个按钮实现去掉字体颜色，谢谢！

最佳答案

月排行榜 / 总排行榜

wayy

2011-11-24 20:50

夏之恋之夏 发表于 2011-11-23 18:49
如何修改呢？

1. Sub AddCor()
   
2. Dim i As Long
   
3. Dim x As Long
   
4. Dim Str As String
   
5. Dim t
   
6. Dim arr
   
7. arr = Range("AO1", [AT65536].End(xlUp))
   
8. For i = 1 To UBound(arr)
   
9. For x = 1 To 6
   
10.   Str = arr(i, x)
    
11.   Select Case Str
    
12.   Case "金"
    
13.     Cells(i, x + 40).Font.ColorIndex = 44
    
14.   Case "木"
    
15.     Cells(i, x + 40).Font.ColorIndex = 50
    
16.   Case "水"
    
17.     Cells(i, x + 40).Font.ColorIndex = 33
    
18.   Case "火"
    
19.     Cells(i, x + 40).Font.ColorIndex = 3
    
20.   Case "土"
    
21.     Cells(i, x + 40).Font.ColorIndex = 16
    
22.   End Select
    
23. Next
    
24. Next
    
25. MsgBox "用时：" & Timer - t
    
26. End Sub

复制代码

跳转到最佳答案楼层

wayy

wayy.rar (32.66 KB, 下载次数: 17)

2011-11-19 15:34 上传

点击文件名下载附件   单元格对象操作起来比较费时间，不知道有没有更好的方法。

夏之恋之夏

为何我插入一列或几列后修改下面的红色地址后没用呢，谢谢！
Sub AddCor()
Dim i As Long
Dim x As Long
Dim Str As String
Dim t
Dim arr
arr = Range("G1", [L65536].End(xlUp))
For i = 1 To UBound(arr)
  For x = 1 To 6
   Str = arr(i, x)
   Select Case Str
   Case "金"
    Cells(i, x + 6).Font.ColorIndex = 44
   Case "木"
    Cells(i, x + 6).Font.ColorIndex = 50
   Case "水"
    Cells(i, x + 6).Font.ColorIndex = 33
   Case "火"
    Cells(i, x + 6).Font.ColorIndex = 3
   Case "土"
    Cells(i, x + 6).Font.ColorIndex = 16
    End Select
  Next
Next
MsgBox "用时：" & Timer - t
End Sub

Sub DelCor()
Range("G1:L65536").Font.ColorIndex = 0
End Sub

夏之恋之夏

请求高手解决，谢谢~

夏之恋之夏

G列至L列要改为AO列至AL列请问代码怎么修改
1.rar (37.98 KB, 下载次数: 9)

2011-11-21 21:42 上传

点击文件名下载附件
重新上传了附近
或者我要多处填色又该如何修改，谢谢！

夏之恋之夏

如何修改呢？

wayy

夏之恋之夏 发表于 2011-11-23 18:49
如何修改呢？

1. Sub AddCor()
   
2. Dim i As Long
   
3. Dim x As Long
   
4. Dim Str As String
   
5. Dim t
   
6. Dim arr
   
7. arr = Range("AO1", [AT65536].End(xlUp))
   
8. For i = 1 To UBound(arr)
   
9. For x = 1 To 6
   
10.   Str = arr(i, x)
    
11.   Select Case Str
    
12.   Case "金"
    
13.     Cells(i, x + 40).Font.ColorIndex = 44
    
14.   Case "木"
    
15.     Cells(i, x + 40).Font.ColorIndex = 50
    
16.   Case "水"
    
17.     Cells(i, x + 40).Font.ColorIndex = 33
    
18.   Case "火"
    
19.     Cells(i, x + 40).Font.ColorIndex = 3
    
20.   Case "土"
    
21.     Cells(i, x + 40).Font.ColorIndex = 16
    
22.   End Select
    
23. Next
    
24. Next
    
25. MsgBox "用时：" & Timer - t
    
26. End Sub

复制代码

mxg825

wayy 发表于 2011-11-24 20:50

这样能否提速一点点。。

1. 
   
2. Sub AddCor1()
   
3. Dim i As Long
   
4. Dim x As Long
   
5. Dim Str As String
   
6. Dim t
   
7. Dim arr
   
8. Dim 金 As Range, 木 As Range, 水 As Range, 火 As Range, 土 As Range
   
9. t = Timer
   
10. Application.ScreenUpdating = False
    
11. arr = Range("AO1", [AT65536].End(xlUp))
    
12. Set 金 = Range("AV2")
    
13. Set 木 = Range("AW2")
    
14. Set 水 = Range("AX2")
    
15. Set 火 = Range("AY2")
    
16. Set 土 = Range("AZ2")
    
17. For i = 1 To UBound(arr)
    
18. For x = 1 To 6
    
19.   Str = arr(i, x)
    
20.   Select Case Str
    
21.   Case "金"
    
22.         Set 金 = Union(金, Cells(i, x + 40))
    
23.   Case "木"
    
24.         Set 木 = Union(木, Cells(i, x + 40))
    
25.   Case "水"
    
26.         Set 水 = Union(水, Cells(i, x + 40))
    
27.   Case "火"
    
28.         Set 火 = Union(火, Cells(i, x + 40))
    
29.   Case "土"
    
30.         Set 土 = Union(土, Cells(i, x + 40))
    
31.   End Select
    
32. Next
    
33. Next
    
34. 金.Font.ColorIndex = 44
    
35. 木.Font.ColorIndex = 50
    
36. 水.Font.ColorIndex = 33
    
37. 火.Font.ColorIndex = 3
    
38. 土.Font.ColorIndex = 16
    
39. Application.ScreenUpdating = True
    
40. MsgBox "用时：" & Timer - t
    
41. End Sub

复制代码

夏之恋之夏

没发现提速，反而代码好像有误，陷入死循环中，EXCEL没有响应了！

mxg825

夏之恋之夏 发表于 2011-11-24 22:15
没发现提速，反而代码好像有误，陷入死循环中，EXCEL没有响应了！

不会死循环呀！
我只是把屏幕刷新 暂时关闭！和最后统一设置！

有提速10% 左右！