绝对高端——漂亮，干净；绝对方便——一键搞定

AIEO.CN

这个应该放哪里？颇费思量。论目的，像是图表，论方法，又是VBA。算了，咱是VBA的常客，还是这里亲切些。

这应该叫什么？权且称为增减趋势图吧。一位也在五百强企业呆过的老同学说，这叫“水瀑图”，他们经常用，很有品位的名字啊。

在外企区域总部，级别很高的会议中经常出现这种图表，要做得漂亮很费力，不过看起来确实直观醒目，让人眼前一亮。

有了这个工具，不必再为做这种图表苦恼了，一键搞定，图表清晰漂亮，不添加冗余列，表格干净整洁。

一段简单的自动演示，包含如何使用加载宏的内容。这种图表，堪称图表皇冠上的明珠，很受老外高管追捧，能轻松拿出这种图表，让人刮目相看哟！

重返论坛以来，连续发了不少东西，希望对大家有所帮助。可能得歇一阵了，忙点别的。

飞云楼主

赶来看看哈。

deweyfbi

老大，能不能告诉密码呀，想学习一下。

shlzml

不太明白具体用法。。楼主如果有空能否录个动画

Aeolian-Vox

多谢分享。
个人建议：设计为自动加载那个加载宏，不要由操作者再选择之。

AIEO.CN

原帖由 Aeolian-Vox 于 2009-6-13 09:21 发表
多谢分享。
个人建议：设计为自动加载那个加载宏，不要由操作者再选择之。

自动演示时会自动添加加载宏，只是每步留了5秒停顿让大家看清添加过程。对新手来说，也多了解点加载宏有关知识。把水瀑图的图片也放上来吧：

[ 本帖最后由 AIEO.CN 于 2009-6-13 10:12 编辑 ]

shlzml

瀑布图 做起来也不难
不过多谢楼主分享 顶了

jiulongpo

原帖由 shlzml 于 2009-6-13 11:00 发表
瀑布图 做起来也不难
不过多谢楼主分享 顶了

下了楼主的附件，感觉操作起来挺麻烦的，对新手而言更不好理解。索性自己做了一个自定义函数，给大
家分享一下。（不适合每月有赤字的，即每月余额小于0）

Sub Newchart()
If MyChart(, xlColumnStacked, Range("B3:B15"), Range("A3:A15"), , , Range("B1")) Then MsgBox "已完成"
End Sub


Function MyChart(Optional ByVal MyChart_Name As String = "我的图表", Optional ByVal MyChart_Type As XlChartType = xlLineMarkers, _
   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 = 420, Optional ByVal MyChart_Top As Integer = 250, _
   Optional ByVal MyChart_Width As Integer = 300, Optional ByVal MyChart_Height As Integer = 200) As Boolean
Dim Mych As ChartObject     '声明变量为嵌入式图表对象
Dim Myarr1, myarr2     '声明数组
ReDim Myarr1(1 To MyChart_Source.Count)      '给数据系列1的数组
ReDim myarr2(1 To MyChart_Source.Count)      '给数据系列2的数组
For k = 1 To UBound(Myarr1)       '以下为把单元格数据分解为数据系列1/2所用的数据
   hz = hz + MyChart_Source.Cells(k, 1)
   Select Case k
   Case 1
      Myarr1(k) = MyChart_Source.Cells(k, 1)
      myarr2(k) = 0
   Case 2 To UBound(Myarr1) - 1
      If MyChart_Source.Cells(k, 1) > 0 Then
         Myarr1(k) = hz - MyChart_Source.Cells(k, 1)
      Else
         Myarr1(k) = hz
      End If
      myarr2(k) = Abs(MyChart_Source.Cells(k, 1))
   Case UBound(Myarr1)
      Myarr1(k) = hz
      myarr2(k) = 0
   End Select
Next
On Error Resume Next     '如出错,则从出错行下一行开始执行
Set Mych = ActiveSheet.ChartObjects(MyChart_Name)     '设置对象
'MsgBox Err.Number
If Err.Number = -2147024809 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      '图表类型为xlLineMarkers_数据点折线图
   .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 ,图表没有图例
   
   .SeriesCollection.NewSeries     '创建新系列
   .SeriesCollection(1).Values = Myarr1    '设置嵌入式图表的系列值1的数据
   For k = 1 To .SeriesCollection(1).Points.Count      '设置系列1的颜色和数据标签
      If k = 1 Or k = .SeriesCollection(1).Points.Count Then
         .SeriesCollection(1).Points(k).Interior.ColorIndex = 5   '2白色 5兰色 3红色 xlColorIndexNone无色
         .SeriesCollection(1).Points(k).ApplyDataLabels Type:=xlDataLabelsShowValue     '显示数据标签
         .SeriesCollection(1).DataLabels(k).Font.ColorIndex = 2   '2白色 5兰色 3红色 xlColorIndexNone无色
      Else
         .SeriesCollection(1).Points(k).Interior.ColorIndex = xlColorIndexNone   '2白色 5兰色 3红色 xlColorIndexNone无色
         .SeriesCollection(1).Points(k).ApplyDataLabels Type:=xlDataLabelsShowNone     '不显示数据标签
      End If
   Next
   .SeriesCollection(1).XValues = MyChart_XValues     '设置水平分类轴标签
   
   .SeriesCollection.NewSeries     '创建新系列
   .SeriesCollection(2).Values = myarr2    '设置嵌入式图表的系列值2的数据
   For k = 1 To .SeriesCollection(2).Points.Count      '设置系列2的颜色和数据标签
      If k = 1 Or k = .SeriesCollection(1).Points.Count Then
         .SeriesCollection(2).Points(k).Interior.ColorIndex = xlColorIndexNone   '2白色 5兰色 3红色 xlColorIndexNone无色
         .SeriesCollection(2).Points(k).ApplyDataLabels Type:=xlDataLabelsShowNone     '不显示数据标签
      Else
         If MyChart_Source.Cells(k, 1) > 0 Then
            .SeriesCollection(2).Points(k).Interior.ColorIndex = 5   '2白色 5兰色 3红色 xlColorIndexNone无色
         Else
            .SeriesCollection(2).Points(k).Interior.ColorIndex = 3   '2白色 5兰色 3红色 xlColorIndexNone无色
         End If
         .SeriesCollection(2).Points(k).ApplyDataLabels Type:=xlDataLabelsShowValue     '显示数据标签
         .SeriesCollection(2).DataLabels(k).Font.ColorIndex = 2   '2白色 5兰色 3红色 xlColorIndexNone无色
      End If
   Next
   .ChartGroups(1).GapWidth = 50     '返回或设置图表的系列和系列之间的间距
End With
Mych.Activate     '对象激活
MyChart = True     '本函数返回True
Exit Function     '退出函数
Myerr:
   MyChart = False     '本函数返回False
End Function

AIEO.CN

原帖由 jiulongpo 于 2009-6-13 18:12 发表

下了楼主的附件，感觉操作起来挺麻烦的，对新手而言更不好理解。索性自己做了一个自定义函数，给大
家分享一下。（不适合每月有赤字的，即每月余额小于0）

真不知道什么叫麻烦？ 加载宏添加后，会出现相关菜单，以后需要做这种图表时，只要选中数字系列，选择菜单“自动作图”就完成了。自动演示只是让新手了解怎样添加加载宏及如何使用该工具，以后无需再演示，也不必非得用附件中的“增减趋势图.xls" 文件。

当然，喜欢琢磨的可以将8楼的代码复制，自己去做工具（可能该代码只适用于2007版）。不过如有新手想了解怎样把代码变成可用的工具，还有劳jiulongpo给予耐心解答 ，咱只负责引玉。

这已经接近“各尽所能，各取所需”的理想境界了。

[ 本帖最后由 AIEO.CN 于 2009-6-13 20:42 编辑 ]

jiulongpo

原帖由 AIEO.CN 于 2009-6-13 20:37 发表


真不知道什么叫麻烦？ 加载宏添加后，会出现相关菜单，以后需要做这种图表时，只要选中数字系列，选择菜单“自动作图”就完成了。自动演示只是让新手了解怎样添加加载宏及如何使用该工具，以后无需再演示，也 ...

见笑了.与君共勉