图表(瀑布图)制作改进

jiulongpo · 发表于 2009-6-16 11:18

图表(瀑布图)制作改进
在上周看到 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 编辑 ]

jiulongpo · 发表于 2009-6-16 19:59

还请喜欢图表的兄弟们给点意见.

hangye · 发表于 2010-1-17 22:15

见笑。怎么用啊跟宏一样用法吗？没反应

hangye · 发表于 2010-1-19 13:06

请教瀑布图的vba代码怎么用啊跟宏一样用法吗？新建宏怎么没反应

byl2005 · 发表于 2010-1-20 20:34

怎么没有附件啊?楼主能否分享一下呢?

jiulongpo · 发表于 2010-1-22 21:41

原帖由 byl2005 于 2010-1-20 20:34 发表
怎么没有附件啊?楼主能否分享一下呢?

请参考：

abc.zip (17.5 KB, 下载次数: 385)

ROCK@ · 发表于 2010-2-4 22:57

那么复杂的啊呀

xc-stone · 发表于 2010-5-14 10:48

很实用，谢谢

jcen · 发表于 2010-5-20 16:46

研究中……

mmf2008 · 发表于 2011-9-26 17:26

论坛强人真多。

		自动登录	找回密码
密码			免费注册

[分享] 图表(瀑布图)制作改进

评分

回复 1楼 jiulongpo 的帖子