[第108期]进度频率图[结束]

wangg913

题目说明
题目的要求以及实现效果，直接见附件，在此就不表述了。

限制规则，任选以下一种规则作图
1、完全使用VBA作图，所有数据系列的值都必须用VBA生成，解答表格不能出现任何辅助列；
2、使用公式、SQl语句或定义名称参与数据系列的构建都可以，此时不限制辅助列的多少，但数据系列最多为6个。

评分规则
1、完全使用VBA作图，奖励技术分1分；
2、（不使用VBA的）其他形式、而且数据系列最多6个，奖励技术分2分；
3、非以上两者，只奖励财富；
4、题目 2014-09-01 终止。
有疑问，请发站内短信息询证

附件

悠悠的炊烟

VBA法

delete_007

用VBA做了一个，请头版有空检验一下（颜色不完全一致，实在找不到你用的什么颜色了。）：

1. Sub AddChart()
   
2.     Dim arr, i%, j%, k%, Frequency%(1 To 6, 1 To 4), Cht
   
3.     Dim ChartCount%, SeriesCol%(1 To 6)
   
4.     arr = Range("a2:b21")
   
5.     For i = 1 To 20
   
6.         Frequency(arr(i, 1), arr(i, 2)) = Frequency(arr(i, 1), arr(i, 2)) + 1
   
7.     Next i
   
8.     ChartCount = ChartObjects.Count
   
9.     If ChartCount = 0 Then
   
10.         Set Cht = Shapes.AddChart.Chart
    
11.     Else
    
12.         Set Cht = ChartObjects(ChartCount).Chart
    
13.         For i = Cht.SeriesCollection.Count To 1 Step -1
    
14.             Cht.SeriesCollection(i).Delete
    
15.         Next i
    
16.     End If
    
17.     With Cht
    
18.         .ChartType = xlColumnClustered
    
19.         For i = 4 To 1 Step -1
    
20.             Erase SeriesCol
    
21.             For j = 1 To 6
    
22.                 If Frequency(j, i) = 0 Then
    
23.                     SeriesCol(j) = 0
    
24.                 Else
    
25.                     SeriesCol(j) = i
    
26.                 End If
    
27.             Next j
    
28.             .SeriesCollection.NewSeries
    
29.             With .SeriesCollection(.SeriesCollection.Count)
    
30.                 .Values = SeriesCol
    
31.                 .Fill.ForeColor.SchemeColor = 31
    
32.                 .Format.ThreeD.BevelTopInset = 6
    
33.                 For k = 1 To 6
    
34.                     If Frequency(k, i) > 1 Then .Points(k).Fill.ForeColor.SchemeColor = 18
    
35.                 Next k
    
36.             End With
    
37.         Next i
    
38.         .ChartGroups(1).GapWidth = 0
    
39.         .ChartGroups(1).Overlap = 100
    
40.         .SetElement (msoElementPrimaryCategoryGridLinesMajor)
    
41.         .SetElement (msoElementPrimaryValueGridLinesMajor)
    
42.         If .HasLegend Then .Legend.Delete
    
43.         With .Axes(xlValue)
    
44.             .MajorTickMark = xlNone
    
45.             .Border.ColorIndex = xlNone
    
46.             .MaximumScale = 4
    
47.             .MajorUnit = 1
    
48.         End With
    
49.         With .Axes(xlCategory)
    
50.             .MajorTickMark = xlNone
    
51.             .Border.ColorIndex = xlNone
    
52.         End With
    
53.         .ChartArea.Border.ColorIndex = xlNone
    
54.     End With
    
55. End Sub

复制代码

oyzhjr

请见附件。


好吧，既然大头版不让取巧，那就上图表吧。

没用VBA，VBA反倒没公式方便了。呵呵 。

好吧，既然限制最多6个数据序列，我再给你省两个。只用4个序列来完成。用XY散点图，取个巧啊。要是气泡图能改气泡的显示方式，那就太爽了。
附件中3改最上面的是图表，下面的两个是用来参照的链接图。

刀羊

试试看吧：   

aoe1981

　　这是我的作业，希望符合要求……
　　
　　我的其实只有两个系列，需要在excel2010中演示。

alzbz

VBA做的。

飞飞在天山

jsxjd

适用于 2003 版：

1. Option Explicit
   
2. Private Sub CommandButton1_Click()
   
3.     RefreshChart
   
4.     [j4].Select
   
5. End Sub
   
6. 
   
7. Private Sub Worksheet_Calculate()
   
8.     RefreshChart
   
9. End Sub
   
10. 
    
11. Sub RefreshChart()
    
12.     Dim i%, j%, c, D%(0 To 6, 0 To 4), SD(1 To 6), cObject As ChartObject, xChart As chart
    
13.     For Each c In Sheets("解答").ChartObjects
    
14.         If c.Name = "xjdChart" Then Set cObject = c: Set xChart = cObject.chart
    
15.     Next
    
16.     If cObject Is Nothing Then
    
17.         Set cObject = Sheets("解答").ChartObjects.Add(100, 30, 340, 220)
    
18.         cObject.Name = "xjdChart"
    
19.         Set xChart = cObject.chart
    
20.         With xChart.SeriesCollection:  .NewSeries: .NewSeries: .NewSeries: .NewSeries: End With
    
21.         With xChart
    
22.             .PlotArea.Width = 300
    
23.             .PlotArea.Height = 200
    
24.             .PlotArea.Border.ColorIndex = xlNone
    
25.             .PlotArea.Interior.ColorIndex = xlNone
    
26.             .ChartGroups(1).Overlap = 100
    
27.             .ChartGroups(1).GapWidth = 0
    
28.             .SeriesCollection(1).Border.ColorIndex = 15
    
29.             .SeriesCollection(1).Interior.ColorIndex = xlNone
    
30.             .HasLegend = False
    
31.             With .Axes(xlValue)
    
32.                 .MinimumScale = 0
    
33.                 .MaximumScale = 4
    
34.                 .MajorUnit = 1
    
35.                 .HasMajorGridlines = True
    
36.                 .MajorGridlines.Border.ColorIndex = 15
    
37.                 .Border.LineStyle = xlNone
    
38.             End With
    
39.             With .Axes(xlCategory)
    
40.                 .HasMajorGridlines = True
    
41.                 .MajorGridlines.Border.ColorIndex = 15
    
42.                 .Border.LineStyle = xlNone
    
43.                 .TickLabels.Font.FontStyle = "加粗"
    
44.             End With
    
45.         End With
    
46.     End If
    
47.    
    
48.     For i = 2 To Range("A" & Rows.Count).End(xlUp).Row
    
49.         D(Cells(i, 1), Cells(i, 2)) = D(Cells(i, 1), Cells(i, 2)) + 1
    
50.     Next
    
51.     For j = 1 To 4
    
52.         For i = 1 To 6: SD(i) = IIf(D(i, j), j, 0): Next
    
53.         xChart.SeriesCollection(5 - j).Values = "={" & Join(SD, ",") & "}"
    
54.         For i = 1 To 6
    
55.             With xChart.SeriesCollection(5 - j).Points(i)
    
56.                 .Border.LineStyle = xlNone
    
57.                 .Fill.TwoColorGradient Style:=msoGradientDiagonalDown, Variant:=1
    
58.                 .Fill.ForeColor.SchemeColor = IIf(D(i, j) > 1, 3, 5)
    
59.                 .Fill.BackColor.SchemeColor = IIf(D(i, j) > 1, 36, 34)
    
60.             End With
    
61.         Next
    
62.     Next
    
63. End Sub
    
64. 
    

复制代码

huahua2005

就这样了:)