[已解决]对应省份的文本框字体显示不同的颜色

木牙水

求助：
希望 对应省份文本框中的名称为F列内容；希望文本框中字体颜色为C列中对应省份的字体颜色。万分感谢啊！
用自带的代码修改了下，不过总是提示错误!

1. Sub fill_color()
   
2. 
   
3.     Application.ScreenUpdating = False    '暂停刷新屏幕
   
4. 
   
5.     For i = 11 To 41  '为数据源的起始和结束行号
   
6. 
   
7.         ActiveSheet.Shapes(Range("DataMap!B" & i).Value).Fill.ForeColor.RGB = Range(Range("DataMap!D" & i).Value).Interior.Color
   
8.         '对各省的图形使用其颜色栏的值作为名称所指向的单元格的颜色填充
   
9.         '         ActiveSheet.Shapes(Range("DataMap!F" & i).Value).ShapeRange.TextFrame2.TextRange.Font.Fill.ForeColor.RGB = Cells(i, 3).Font.Color
   
10.         '         '对各省的图形标签字体颜色栏的值作为名称所指向的单元格的颜色填充
    
11.         '
    
12.                     ActiveSheet.Shapes(Range("DataMap!F" & i).Value).TextFrame.Characters.Font.Color.RGB = Cells(i, 3).Font.Color
    
13.       
    
14.     Next i
    
15. 
    
16.     Application.ScreenUpdating = True    '恢复刷新屏幕
    
17. 
    
18. End Sub
    
19. 
    

复制代码

20150906-全国生猪价格生成模板.rar (945.77 KB, 下载次数: 11)

2015-9-6 09:58 上传

点击文件名下载附件

最佳答案

月排行榜 / 总排行榜

gufengaoyue

2015-9-7 14:19

爱疯 发表于 2015-9-7 09:30
勾上 显示省份名称 或 显示数值，我还没看出来是用什么方式来显示的 ... 楼主知道么

A列是有公式的。

1. Sub fill_color()
   
2. Dim myColor&
   
3.     Application.ScreenUpdating = False    '暂停刷新屏幕
   
4.     For i = 11 To 41  '为数据源的起始和结束行号
   
5.         ActiveSheet.Shapes(Range("DataMap!B" & i).Value).Fill.ForeColor.RGB = Range(Range("DataMap!D" & i).Value).Interior.Color
   
6.         myColor = IIf(Cells(i, 3) > Cells(i, 5), vbGreen, IIf(Cells(i, 3) < Cells(i, 5), vbRed, vbBlack))
   
7.       ActiveSheet.Shapes(Range("DataMap!F" & i).Value).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = myColor
   
8.     Next i
   
9.     Application.ScreenUpdating = True    '恢复刷新屏幕
   
10. End Sub

复制代码

跳转到最佳答案楼层

爱疯

勾上 显示省份名称 或 显示数值，我还没看出来是用什么方式来显示的 ... 楼主知道么

金樽空对月

首先，C列内的字体颜色是条件格式设置而成的，这种效果的颜色它只是表面显示的颜色，但实际上的颜色还是默认的黑色，建议C列的条件格式颜色你还是用段代码来实现，这样它的颜色就可以引用到文本框内了。
看来你们都是高人，代码怎么编写我就不现丑了。
不过楼主你那个地图上的文字效果是怎么实现的，能不能分享一下？

gufengaoyue

爱疯 发表于 2015-9-7 09:30
勾上 显示省份名称 或 显示数值，我还没看出来是用什么方式来显示的 ... 楼主知道么

A列是有公式的。

1. Sub fill_color()
   
2. Dim myColor&
   
3.     Application.ScreenUpdating = False    '暂停刷新屏幕
   
4.     For i = 11 To 41  '为数据源的起始和结束行号
   
5.         ActiveSheet.Shapes(Range("DataMap!B" & i).Value).Fill.ForeColor.RGB = Range(Range("DataMap!D" & i).Value).Interior.Color
   
6.         myColor = IIf(Cells(i, 3) > Cells(i, 5), vbGreen, IIf(Cells(i, 3) < Cells(i, 5), vbRed, vbBlack))
   
7.       ActiveSheet.Shapes(Range("DataMap!F" & i).Value).TextFrame2.TextRange.Font.Fill.ForeColor.RGB = myColor
   
8.     Next i
   
9.     Application.ScreenUpdating = True    '恢复刷新屏幕
   
10. End Sub

复制代码

爱疯

gufengaoyue 发表于 2015-9-7 14:19
A列是有公式的。

谢谢gufengaoyue ！

明白了

木牙水

gufengaoyue 发表于 2015-9-7 14:19
A列是有公式的。

非常感谢，代码很简洁！
我对shapes对象属性太不清楚了。
我用笨方法也写了一段，目的是实现了，就是要加一句
On Error Resume Next，不知道为何？

1. Sub fill_color()
   
2. Application.ScreenUpdating = False '暂停刷新屏幕
   
3. On Error Resume Next
   
4. ' 全国的图
   
5. For i = 11 To 41 '为数据源的起始和结束行号
   
6. ActiveSheet.Shapes(Range("DataMap!B" & i).Value).Fill.ForeColor.RGB = Range(Range("DataMap!D" & i).Value).Interior.Color
   
7. '对各省的图形使用其颜色栏的值作为名称所指向的单元格的颜色填充
   
8. If Cells(i, 3).Value > Cells(i, 5).Value Then Sheet1.Shapes(Range("DataMap!F" & i).Value).TextFrame.Characters.Font.Color = -16776961
   
9. If Cells(i, 3).Value = Cells(i, 5).Value Then Sheet1.Shapes(Range("DataMap!F" & i).Value).TextFrame.Characters.Font.ColorIndex = xlAutomatic
   
10. If Cells(i, 3).Value < Cells(i, 5).Value Then Sheet1.Shapes(Range("DataMap!F" & i).Value).TextFrame.Characters.Font.Color = -11489280
    
11. Next i
    
12. ' 山东省图
    
13. For j = 49 To 65 '为数据源的起始和结束行号
    
14. ActiveSheet.Shapes(Range("DataMap!B" & j).Value).Fill.ForeColor.RGB = Range(Range("DataMap!D" & j).Value).Interior.Color
    
15. '对各省的图形使用其颜色栏的值作为名称所指向的单元格的颜色填充
    
16. If Cells(j, 3).Value > Cells(j, 5).Value Then Sheet1.Shapes(Range("DataMap!F" & j).Value).TextFrame.Characters.Font.Color = -16776961
    
17. If Cells(j, 3).Value = Cells(j, 5).Value Then Sheet1.Shapes(Range("DataMap!F" & j).Value).TextFrame.Characters.Font.ColorIndex = xlAutomatic
    
18. If Cells(j, 3).Value < Cells(j, 5).Value Then Sheet1.Shapes(Range("DataMap!F" & j).Value).TextFrame.Characters.Font.Color = -11489280
    
19. Next j
    
20. Application.ScreenUpdating = True '恢复刷新屏幕
    
21. 
    
22. End Sub
    
23. 
    

复制代码

另外我把山东的地图也加上了，需要的朋友可以下载。
20150907-全国和山东生猪价格生成模板.part1.rar (1 MB, 下载次数: 11)

2015-9-7 18:53 上传

点击文件名下载附件
20150907-全国和山东生猪价格生成模板.part2.rar (491 Bytes, 下载次数: 6)

2015-9-7 18:53 上传

点击文件名下载附件