|
|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
图表(瀑布图)制作改进
在上周看到 AIEO.CN 发的贴子,用加载宏制作的自动生成瀑布图,很是羡慕.原贴:http://club.excelhome.net/viewthread.php?tid=446661&;page=1#pid2898443
曾经自己也手工做过瀑布图,虽说不是太难,就是过于繁锁.遂产生自己也来做一个自动生成的代码,并跟贴发表.
使用中发现, AIEO.CN 发加载宏与自己做的代码都有几个问题没有解决:
1.这是个致命的缺陷,当每月有赤字,即每月余额小于等于0的时候,图表会显示错误的信息.
2.图表中系列的颜色与数据有时会不一致,即当数据为负数时显示红色,当数据为正数时显示兰色.
3.图表中系列的标签文本与数据有些不一致,即当数据为负数时显示负数,当数据为正数时显示正数.
4.本人制作的代码为Excel2007的兼容模式,与2003兼容差,想用2003来写一个代码.
现在,针对以上问题,终于解决完成了.
以下为改进后代码:
'调用过程------------------------------------------------------------------------------------------------------------------
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("B3:B14")) Is Nothing And Target.Row > 2 Then
a = MyChart("瀑布图例", xlColumnStacked, Range("B3:B14"), Range("A3:A15"), , , Range("B1"))
End If
End Sub
'自定义函数------------------------------------------------------------------------------------------------------------------
Function MyChart(Optional ByVal MyChart_Name As String = "我的图表", Optional ByVal MyChart_Type As XlChartType = xlColumnClustered, _
Optional ByVal MyChart_Source As Range = Nothing, Optional ByVal MyChart_XValues As Range = Nothing, _
Optional ByVal MyChart_Plotby As XlRowCol = xlRows, Optional ByVal MyChart_Title As Boolean = True, _
Optional ByVal MyChart_TitleText As String = "标题", Optional ByVal MyChart_HasLegend As Boolean = False, _
Optional ByVal MyChart_Left As Integer = 400, Optional ByVal MyChart_Top As Integer = 200, _
Optional ByVal MyChart_Width As Integer = 300, Optional ByVal MyChart_Height As Integer = 200) As Boolean
'参数 (可选):
'MyChart_Name As String = "我的图表" 字符型,设置图表的名称,默认值="我的图表"
'MyChart_Type As XlChartType = xlColumnClustered XlChartType枚举,设置图表类型,默认值=xlColumnClustered簇状柱形图
'MyChart_Source As Range = Nothing 单元格对象,设置图表系列的数据源,默认为空
'MyChart_XValues As Range = Nothing 单元格对象,设置图表水平分类轴标签,默认为空
'MyChart_Plotby As XlRowCol = xlRows XlRowCol枚举,设置图表数据系列的数值是处于行中还是列中,默认值=xlRows行中
'MyChart_Title As Boolean = True 布尔型,设置图表有可见标题,默认值=True有可见标题
'MyChart_TitleText As String = "标题" 字符型,设置图表的标题文本,默认值="标题"
'MyChart_HasLegend As Boolean = False 布尔型,设置图表有图例,默认值=False没有图例
'MyChart_Left As Integer = 400 整型,设置图表的左边距,默认值=400
'MyChart_Top As Integer = 200 整型,设置图表的上边距,默认值=200
'MyChart_Width As Integer = 300 整型,设置图表的宽度,默认值=300
'MyChart_Height As Integer = 200 整型,设置图表的高度,默认值=200
Dim Mych As ChartObject '声明变量为嵌入式图表对象
Dim Myarr1, Myarr2, Myarr3 '声明数组
ReDim Myarr1(1 To MyChart_Source.Count + 1) '给数据系列1的数组
ReDim Myarr2(1 To MyChart_Source.Count + 1) '给数据系列2的数组
ReDim Myarr3(1 To MyChart_Source.Count + 1) '给数据系列1是否显示的数组
For k = 1 To MyChart_Source.Count + 1 '以下为把单元格数据分解为数据系列1/2所用的数据
If k = MyChart_Source.Count + 1 Then Myarr1(k) = hz: Myarr2(k) = 0: Myarr3(k) = 1: GoTo Myexit
hz = hz + MyChart_Source.Cells(k, 1)
If k = 1 Then Myarr1(k) = MyChart_Source.Cells(k, 1): Myarr2(k) = 0: Myarr3(k) = 1: GoTo Myexit
Select Case hz
Case Is = 0
If hz - MyChart_Source.Cells(k, 1) > 0 Then
Myarr1(k) = 0
Myarr2(k) = -MyChart_Source.Cells(k, 1)
Else
Myarr1(k) = 0
Myarr2(k) = -MyChart_Source.Cells(k, 1)
End If
Case Is > 0
If MyChart_Source.Cells(k, 1) > 0 Then
Myarr1(k) = hz - MyChart_Source.Cells(k, 1)
Myarr2(k) = Abs(MyChart_Source.Cells(k, 1))
Else
Myarr1(k) = hz
Myarr2(k) = Abs(MyChart_Source.Cells(k, 1))
End If
If MyChart_Source.Cells(k, 1) > hz Then
Myarr1(k) = hz - MyChart_Source.Cells(k, 1)
Myarr2(k) = hz
Myarr3(k) = 1
End If
Case Is < 0
If MyChart_Source.Cells(k, 1) > 0 Then
Myarr1(k) = hz
Myarr2(k) = -Abs(MyChart_Source.Cells(k, 1))
Else
Myarr1(k) = hz - MyChart_Source.Cells(k, 1)
Myarr2(k) = -Abs(MyChart_Source.Cells(k, 1))
End If
If MyChart_Source.Cells(k, 1) < hz Then
Myarr1(k) = hz
Myarr2(k) = hz - MyChart_Source.Cells(k, 1)
Myarr3(k) = 1
End If
End Select
Myexit:
Next
On Error Resume Next '如出错,则从出错行下一行开始执行
Set Mych = ActiveSheet.ChartObjects(MyChart_Name) '设置对象
'MsgBox Err.Number
If Err.Number <> 0 Then '设置对象出错,没有对象
Set Mych = ActiveSheet.ChartObjects.Add(MyChart_Left, MyChart_Top, MyChart_Width, MyChart_Height) '添加嵌入图表,设置对象
Mych.Name = MyChart_Name '设置对象名称
End If
Err.Clear '清除Err对象
On Error GoTo Myerr '如出错,则执行Myerr语句
With Mych.Chart
.ChartType = MyChart_Type '图表类型为xlColumnStacked_堆积柱形图
For k = .SeriesCollection.Count To 1 Step -1
.SeriesCollection(k).Delete '删除数据系列
Next
.SeriesCollection.NewSeries '创建新系列
With .SeriesCollection(1) '设置系列1---------------------------------------------------------
.Values = Myarr1 '设置嵌入式图表的系列值1的数据
For k = 1 To .Points.Count '设置系列1的颜色和数据标签
.Points(k).Interior.ColorIndex = xlColorIndexNone '2白色 5兰色 3红色 xlColorIndexNone无色
.Points(k).ApplyDataLabels Type:=xlDataLabelsShowNone '不显示数据标签
.Points(k).Border.LineStyle = xlNone '无边框线
If k = 1 Or k = .Points.Count Then
.Points(k).ApplyDataLabels Type:=xlDataLabelsShowValue '显示数据标签
.Points(k).DataLabel.Font.ColorIndex = 2 '2白色 5兰色 3红色 xlColorIndexNone无色
End If
If Len(Myarr3(k)) > 0 And MyChart_Source.Cells(k, 1) > 0 Then
.Points(k).Interior.ColorIndex = 5 '2白色 5兰色 3红色 xlColorIndexNone无色
End If
If Len(Myarr3(k)) > 0 And MyChart_Source.Cells(k, 1) < 0 Then
.Points(k).Interior.ColorIndex = 3 '2白色 5兰色 3红色 xlColorIndexNone无色
End If
If k = .Points.Count And Myarr1(k) > 0 Then
.Points(k).Interior.ColorIndex = 5 '2白色 5兰色 3红色 xlColorIndexNone无色
End If
If k = .Points.Count And Myarr1(k) < 0 Then
.Points(k).Interior.ColorIndex = 3 '2白色 5兰色 3红色 xlColorIndexNone无色
End If
Next
.XValues = MyChart_XValues '设置水平分类轴标签'
End With
.SeriesCollection.NewSeries '创建新系列
With .SeriesCollection(2) '设置系列2---------------------------------------------------------
.Values = Myarr2 '设置嵌入式图表的系列值2的数据
For k = 1 To .Points.Count '设置系列2的颜色和数据标签
.Points(k).Interior.ColorIndex = 3 '2白色 5兰色 3红色 xlColorIndexNone无色
.Points(k).ApplyDataLabels Type:=xlDataLabelsShowValue '显示数据标签
.Points(k).Border.LineStyle = xlNone '无边框线
If k = 1 Or k = .Points.Count Then
.Points(k).ApplyDataLabels Type:=xlDataLabelsShowNone '不显示数据标签
End If
If MyChart_Source.Cells(k, 1) > 0 Then
.Points(k).Interior.ColorIndex = 5 '2白色 5兰色 3红色 xlColorIndexNone无色
Else
.Points(k).Interior.ColorIndex = 3 '2白色 5兰色 3红色 xlColorIndexNone无色
End If
If k > 1 And k < .Points.Count Then
.Points(k).DataLabel.Text = MyChart_Source.Cells(k, 1)
.Points(k).DataLabel.Font.ColorIndex = 2 '2白色 5兰色 3红色 xlColorIndexNone无色
End If
Next
End With
.HasTitle = MyChart_Title '图表标题，可见则为 True
If MyChart_Title Then .ChartTitle.Characters.Text = MyChart_TitleText '图表标题文本
'.ChartTitle.Characters.Font.Size = 12 '设置标题的字号
'.SetSourceData Source:=Myarr, PlotBy:=MyChart_Plotby '为指定图表设置源数据区域
.HasLegend = MyChart_HasLegend '为False ,图表没有图例
.ChartGroups(1).GapWidth = 30 '返回或设置图表的系列和系列之间的间距
End With
'Mych.Activate '对象激活
MyChart = True '本函数返回True
Exit Function '退出函数
Myerr:
MyChart = False '本函数返回False
End Function
[ 本帖最后由 jiulongpo 于 2009-6-29 19:42 编辑 ] |
评分
-
1
查看全部评分
-
|
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2009-6-16 11:18
楼主
