楼主
raulerini |
前不久看到刘万祥老师用EXCEL制作出了类似仪表盘的炫图，觉得非常震撼
我仅仅是将纯技巧操作的部分进行了VBA程式化。
说明如下：
raulerini 根据刘万祥老师思路整理编写而成
主要改进之处:
1、不用建立辅助单元格区域，就能快速准确的生成仪表盘到指定单元格位置
2、仪表盘的刻度标签不用辅助插件来生成，且会随着两端极值的变动而变动
注意点：1、仅在2003版本中测试，2007以上高版本请自行修改
2、使用时注意活动单元格要为空白单元格
操作如下图：
代码：
- Sub addchart()
- 'On Error Resume Next
- If Application.Version <> 11 Then MsgBox "此程序仅在2003版本下完成测试，请用2003打开！": Exit Sub
- If Selection.Value <> "" Then Exit Sub
- Dim mychart As Chart, zhibiao As Range, mybottom As Range, mytop As Range
- Set rng = Application.InputBox("请选择数据区域的范围：" & vbCrLf & "数据按照[指标值],[最小值],[最大值]纵向排列", "选择数据", , , , , , 8)
- Set zhibiao = rng(1)
- Set mybottom = rng(2)
- Set mytop = rng(3)
- ThisWorkbook.Names.Add Name:="内圈标签", RefersTo:="={0;27;0;27;0;27;0;27;0;27;0;27;0;27;0;27;0;27;0;27;0;0;90}"
- ThisWorkbook.Names.Add Name:="预警色带", RefersTo:="={270;18;54;18}"
- ThisWorkbook.Names.Add Name:="指针", RefersTo:="=CHOOSE({1;2;3},(" & zhibiao.Address(1, 1) & "-" & _
- mybottom.Address(1, 1) & ")/(" & mytop.Address(1, 1) & "-" & mybottom.Address(1, 1) & ")*270,0,360-(" & zhibiao.Address(1, 1) & "-" & _
- mybottom.Address(1, 1) & ")/(" & mytop.Address(1, 1) & "-" & mybottom.Address(1, 1) & ")*270)"
- For kk = 1 To 11
- ThisWorkbook.Names.Add Name:="标签" & kk, RefersTo:="=round(" & mybottom.Address(1, 1) & "+(" & mytop.Address(1, 1) & "-" & _
- mybottom.Address(1, 1) & ")/10*" & kk - 1 & ",0)"
- Next
- ThisWorkbook.Names.Add Name:="指标值", RefersTo:="=" & zhibiao.Parent.Name & "!" & zhibiao.Address(1, 1)
- Set mychart = ActiveSheet.ChartObjects.Add(ActiveCell.Left, ActiveCell.Top, 250, 250).Chart
- With mychart
- .ChartType = xlDoughnut
- .HasLegend = False
- With .SeriesCollection.NewSeries
- .Values = "='" & ThisWorkbook.Name & "'!内圈标签"
- .Name = "内圈标签"
- .ApplyDataLabels ShowValue:=True
- .Interior.ColorIndex = xlNone
- .Border.LineStyle = xlNone
- End With
- With .SeriesCollection.NewSeries
- .Values = "='" & ThisWorkbook.Name & "'!预警色带"
- .Name = "预警色带"
- For i = 2 To 4
- .Points(i).Interior.ColorIndex = xlNone
- .Points(i).Border.LineStyle = xlNone
- Next
- End With
- With .SeriesCollection.NewSeries
- .Values = "='" & ThisWorkbook.Name & "'!内圈标签"
- .Name = "外圈标签"
- .Border.Color = vbWhite
- .Interior.ColorIndex = 15
- End With
- With .ChartGroups(1)
- .FirstSliceAngle = 225
- .DoughnutHoleSize = 65
- End With
- With .SeriesCollection(2).Points(1).Fill
- .ForeColor.SchemeColor = 46
- .BackColor.SchemeColor = 4
- .TwoColorGradient msoGradientVertical, 1
- End With
- For j = 1 To 23
- With .SeriesCollection(1).Points(j).DataLabel
- If j = 23 Then .Text = "='" & ThisWorkbook.Name & "'!指标值"
- If j Mod 2 Then
- .Text = "='" & ThisWorkbook.Name & "'!标签" & (j + 1) / 2
- .Font.Size = 9
- Else
- .Delete
- End If
- End With
- Next
- .PlotArea.Interior.ColorIndex = xlNone
- .PlotArea.Border.LineStyle = 0
- .ChartArea.Interior.ColorIndex = xlNone
- .ChartArea.Border.LineStyle = 0
- With .SeriesCollection.NewSeries
- .Values = "='" & ThisWorkbook.Name & "'!指针"
- .ChartType = xlPie
- .Explosion = 30
- For k = 1 To 3
- .Points(k).Explosion = 0
- .Points(k).Interior.ColorIndex = IIf(k Mod 2, xlNone, 3)
- .Points(k).Border.ColorIndex = IIf(k Mod 2, xlNone, 3)
- Next
- End With
- .SeriesCollection(1).Points(23).DataLabel.Top = .SeriesCollection(1).Points(23).DataLabel.Top - 45
- .ChartGroups(2).FirstSliceAngle = 225
- .Shapes.AddShape msoShapeOval, .PlotArea.Left + .PlotArea.Width / 2 - 5, .PlotArea.Top + .PlotArea.Height / 2 - 5, 12#, 12#
- End With
- End Sub
 纯图表的仪表盘 豪华版 .rar
|