[第102期]堆积柱形和柱形混搭图[已总结]

悠悠的炊烟 · 发表于 2014-2-17 23:18

本帖最后由 delete_007 于 2014-3-26 08:49 编辑

对于会VBA的人来说，你只需要再学一点点图表就。。。，no sweat（小菜一碟）；
对于会函数的人来说，我想应该也只需要再学一点点图表就。。。，a piece of cake（一碟小菜）；
对于会图表的人呢？那就再学一点VBA和函数吧
-------------------------------------------------------------------------------------------------------------------------------------------------------------------
补充说明：表1数据源区域为：A4:K8，水果、蔬菜的增减也只发生在该区域，且通过覆盖的方式（非插入或删除列）来更新数据源。

截止日期： 2014-2-27至2014-3-25
评分：完全达到附件要求的得2分

delete_007 · 发表于 2014-2-28 08:49

本帖最后由 delete_007 于 2014-3-12 09:16 编辑

先交一份答案吧，后面再修改。标签位置未达到题目要求。

函数感觉搞不定了，改写代码吧。摸索了很久，总算达到目的了。
添加了注释，方便阅读。

Option Explicit
Sub AddChart()
Dim arr, brr, i%, j%, k%, m%, Ser#(15), X$(15), FuZu%(15)
On Error Resume Next
Application.ScreenUpdating = False '关闭屏幕刷新
ChartObjects.Delete '删除已有表格
arr = Range("A4:K8") '作图所需数据源表1
brr = Range("A12:B21") '表2
Charts.Add '添加图表
ActiveChart.SeriesCollection(1).Delete '删除图表中已有的数据系列
ActiveChart.Location xlLocationAsObject, "题目要求" '指定图表的位置
ActiveChart.ChartType = xlColumnStacked '设置图表类型为堆积柱形图
'设置横坐标数组
For k = 0 To 15
If k Mod 4 = 1 Then
X(k) = arr(Int(k / 4) + 2, 1)
Else
X(k) = ""
End If
Next
'从表1的第2列开始循环，为图表插入数据系列
For i = 2 To UBound(arr, 2)
If arr(1, i) <> "" Then '如果arr(1,i)为空，表明数据系列已添加完毕
If arr(1, i) = "损益" Then
m = 2 '将损益列的数据放在余数是2的行
Else
j = 0
Do
j = j + 1
Loop Until brr(j, 1) = arr(1, i)
If brr(j, 2) = "水果" Then
m = 0 '将水果列的数据放在余数是0的行
Else
m = 1 '将蔬菜列的数据放在余数是1的行
End If
End If
'根据arr(1,i)所属类型，重生成作图所需数据
For k = 0 To 15
If k Mod 4 = m Then
Ser(k) = arr(Int(k / 4) + 2, i)
Else
Ser(k) = 0
End If
Next
ActiveChart.SeriesCollection.NewSeries '为图表添加新数据系列
'为新数据系列设置名称、X轴值、数据值
With ActiveChart.SeriesCollection(i - 1)
.Name = arr(1, i)
.XValues = X
.Values = Ser
End With
End If
Next
'设置图表格式
With ActiveChart
.ChartGroups(1).GapWidth = 0 '分类间距为0
.Axes(xlValue).MajorUnit = 50 'Y轴主要刻度为50
.Axes(xlValue).MajorTickMark = xlNone 'Y轴主要刻度线无
.Axes(xlValue).Border.ColorIndex = xlNone 'Y轴线条颜色无线条
.Axes(xlCategory).Crosses = xlMaximum '纵坐标轴交叉于最大分类
.Axes(xlCategory).MajorTickMark = xlNone '横轴主要刻度线无
.Axes(xlValue).Crosses = xlMinimum '横坐标轴交叉于最小值
.SetElement (msoElementLegendTop) '在顶部显示图例
'添加辅助数据系列，模拟标签
.SeriesCollection.NewSeries
With .SeriesCollection(.SeriesCollection.Count)
.Name = "FZ"
.XValues = X
.Values = FuZu '添加全是0值的辅助数据系列
.AxisGroup = 2 '系列绘制在次坐标轴上
.ChartType = xlLine '拆线图
.Border.ColorIndex = xlNone '线条颜色无线条
'根据损益值设置自定义标签
For i = 0 To 15
If Ser(i) = 0 Then
.Points(i + 1).HasDataLabel = False
'0值不显示标签
ElseIf Ser(i) > 0 Then '正值显示标签于下方
.Points(i + 1).HasDataLabel = True
.Points(i + 1).DataLabel.Text = Ser(i)
.Points(i + 1).DataLabel.Position = 1
ElseIf Ser(i) < 0 Then '负值显示标签于上方，并设置字体为红色
.Points(i + 1).HasDataLabel = True
.Points(i + 1).DataLabel.Text = Ser(i)
.Points(i + 1).DataLabel.Font.ColorIndex = 3
.Points(i + 1).DataLabel.Position = 0
End If
Next
End With
'设置次坐标轴格式
With .Axes(xlValue, xlSecondary)
.MinimumScale = ActiveChart.Axes(xlValue).MinimumScale
'次坐标轴与主坐标轴最小值相同
.MaximumScale = ActiveChart.Axes(xlValue).MaximumScale
'次坐标轴与主坐标轴最大值相同
.MajorUnit = 50 '次坐标轴主要刻度与主坐标轴相同为50
.MajorTickMark = xlNone '主要刻度线无
.TickLabelPosition = xlNone '不显示坐标轴标签
.Border.ColorIndex = xlNone '不显示坐标轴线条
End With
.Legend.LegendEntries(.Legend.LegendEntries.Count).Delete
'删除辅助数据系列的图例
End With
Application.ScreenUpdating = True '开启屏幕刷新
End Sub

复制代码

lolmuta · 发表于 2014-2-28 22:16

本帖最后由 lolmuta 于 2014-2-28 22:20 编辑

这对我来说有满有挑战性的…
说实在的，那个datalabel究竟要怎样才能上标哩…

因为在stack 表里面，column是会叠在一起的，所以标示决不会在column外面

不过勉强做出来了

lolmuta · 发表于 2014-3-6 20:30

lolmuta 发表于 2014-2-28 22:16
这对我来说有满有挑战性的…
说实在的，那个datalabel究竟要怎样才能上标哩…

已修正!!

alzbz · 发表于 2014-3-9 15:35

VBA做的。

wudixin96 · 发表于 2014-3-12 15:23

本帖最后由 wudixin96 于 2014-3-12 19:43 编辑

请烟老师指点，这多格式的，累死俺了。

apirl2008 · 发表于 2014-3-13 11:12

用函数+数据透视图。。。。。准确的说，还没完全一致，所以就只看看图片吧

cleverzhzhf · 发表于 2014-3-13 17:20

哎。。。水平就顶到这了。。。图可以动态，但是图例没办法了。。。
在L2写公式，并拖到X28（709字符的9层IF嵌套公式呀，有不少可以简化的，懒得弄了~~）：

=IF(ROW()=12,IF(COLUMN()=12,"",IF(COLUMN()>=23,"损益",IF(COLUMN()>COUNTA($4:$4)+11,"",OFFSET($A$4,,COLUMN()-13)))),
IF(COLUMN()=12,IF(MOD(ROW(),4)=2,-50,""),
IF(COLUMN()=13,IF(MOD(ROW(),4)=2,"Q"&INT(ROW()/4)-2,""),
IF(COLUMN()=23,IF(MOD(ROW(),4)=3,OFFSET(INDIRECT(CHAR(64+COUNTA($4:$4))&4),INT(ROW(3:3)/4),),0),
IF(COLUMN()=24,IF(MOD(ROW(),4)=3,-OFFSET(INDIRECT(CHAR(64+COUNTA($4:$4))&4),INT(ROW(3:3)/4),),0),
IF(OR(MOD(ROW(),4)=0,L$12=""),0,IF(L$12="损益",IF(MOD(ROW(),4)=3,OFFSET($A$4,INT(ROW(3:3)/4),COLUMN()-13),0),IF(AND(VLOOKUP(L$12,$A:$B,2,)="水果",MOD(ROW(),4)=1),OFFSET($A$4,INT(ROW(3:3)/4),COLUMN()-13),IF(AND(VLOOKUP(L$12,$A:$B,2,)="蔬菜",MOD(ROW(),4)=2),OFFSET($A$4,INT(ROW(3:3)/4),COLUMN()-13),0)))))))))

复制代码

cjh-01 · 发表于 2014-3-14 09:31

好长时间未发帖了，参与参与。感谢烟美女的好题！

sunya_0529 · 发表于 2014-3-23 19:19

本帖最后由 sunya_0529 于 2014-3-23 19:20 编辑

额外写了一个随机生成数据源的代码，再加上“一键制图”的代码，如下——

Option Explicit
Private Sub CommandButton1_Click() '随机生成源数据
Application.ScreenUpdating = False
Dim i%, j%, str$, s$, arr() As String
[B4:K8].ClearContents '清空数据区域
i = Int(Rnd() * 6 + 4) '随机取出若干品种
ReDim arr(i) '重定义数组维度
str = "123456789" '定义随机抽取品种母序列
Do '循环抽取随机品种
s = Val(Mid(str, Int(Rnd() * Len(str) + 1), 1))
arr(j) = Range("A" & s + 12)
str = Replace(str, s, "")
j = j + 1
Loop While j <= i
arr(i) = "损益"
[B4].Resize(1, i + 1) = arr '写入表头
[B5].Resize(4, i) = "=INT(RAND()*89+10)" '生成10~99之间的随机数
Range(ActiveSheet.Cells(5, i + 2), ActiveSheet.Cells(8, i + 2)) = "=INT(RAND()*98+1)-50" '生成±49~0之间的随机数
[B5].Resize(4, i + 1).Copy
[B5].Resize(4, i + 1).PasteSpecial xlPasteValues
Application.CutCopyMode = False
[B5].Select
Application.ScreenUpdating = True
End Sub
Private Sub CommandButton2_Click() '一键制图
'构建数据源区域
With ActiveSheet
Dim arr(15, 11), k As Range, i%, j%
arr(0, 0) = "季度"
arr(2, 0) = "Q1"
arr(6, 0) = "Q2"
arr(10, 0) = "Q3"
arr(14, 0) = "Q4"
j = [B4].End(xlToRight).Column - 1
For Each k In Range([B4], .Cells(4, [B4].End(xlToRight).Column - 1))
If Application.VLookup(k.Value, [A13:B21], 2, 0) = "水果" Then
i = i + 1
arr(0, i) = k
arr(1, i) = k.Offset(1, 0)
arr(5, i) = k.Offset(2, 0)
arr(9, i) = k.Offset(3, 0)
arr(13, i) = k.Offset(4, 0)
Else
j = j - 1
arr(0, j) = k
arr(2, j) = k.Offset(1, 0)
arr(6, j) = k.Offset(2, 0)
arr(10, j) = k.Offset(3, 0)
arr(14, j) = k.Offset(4, 0)
End If
Next
j = [B4].End(xlToRight).Column
arr(0, j - 1) = .Cells(4, j)
arr(3, j - 1) = .Cells(5, j)
arr(7, j - 1) = .Cells(6, j)
arr(11, j - 1) = .Cells(7, j)
arr(15, j - 1) = .Cells(8, j)
arr(0, j) = .Cells(4, j)
arr(3, j) = -Val(.Cells(5, j).Value)
arr(7, j) = -Val(.Cells(6, j).Value)
arr(11, j) = -Val(.Cells(7, j).Value)
arr(15, j) = -Val(.Cells(8, j).Value)
Sheets(2).Cells.ClearContents
Sheets(2).[A1].Resize(16, 12) = arr
End With
'生成图表
Dim w As Shape, x As Chart, t%
For Each w In ActiveSheet.Shapes
If w.Type = msoChart Then w.Delete
Next
t = Sheets(2).[A1].End(xlToRight).Column - 1
Set x = ActiveSheet.Shapes.AddChart.Chart
With x
.ChartType = xlColumnStacked
.SetSourceData Source:=Sheets(2).[B1].Resize(16, t) '选择数据源
.PlotBy = xlColumns
.ChartGroups(1).GapWidth = 0 '列簇间距为0
.Legend.Position = xlLegendPositionTop '图例项置顶显示
.Legend.LegendEntries(t).Delete
.Axes(xlCategory).MajorTickMark = xlNone '无横坐标刻度线
.Axes(xlCategory).TickLabelPosition = xlLow '横坐标标签位置置底
.SeriesCollection(1).XValues = "=Sheet2!$A$2:$A$16" '设置横坐标标签
.SeriesCollection(t).ApplyDataLabels
.SeriesCollection(t).DataLabels.Position = xlLabelPositionInsideBase
.SeriesCollection(t).DataLabels.NumberFormatLocal = "[红色]-0;0;;"
.SeriesCollection(t).Format.Fill.Visible = msoFalse
.Axes(xlValue).MajorTickMark = xlNone '无主纵坐标轴刻度线
.Axes(xlValue).TickLabelPosition = xlTickLabelPositionHigh '主纵坐标轴标签显示在右侧
.Axes(xlValue).Format.Line.Visible = msoFalse '无主纵坐标轴线
End With
Set x = Nothing
End Sub

复制代码

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

[Excel 图表] [第102期]堆积柱形和柱形混搭图[已总结]

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

点评

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

本帖子中包含更多资源

评分

浏览过的版块