1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
|
Const mc_sglWIDTH As Single = 100
Const mc_sglHEIGHT As Single = 200
Const mc_sglGAP As Single = 10
Private Type ClassData
ClassName As String
GradeData(1 To 2, 1 To 3) As Double
FillColour(1 To 3) As Long
End Type
Sub AddCharts()
Dim lngLastRow As Long
Dim lngRow As Long
Dim wks As Worksheet
Dim wksCharts As Worksheet
Dim objClassData(1 To 1) As ClassData
Dim sglTop As Single
Dim sglLeft As Single
Dim strClass As String
Dim varData As Variant
Application.ScreenUpdating = False
Set wks = Sheets("q_for_report")
Set wksCharts = Sheets.Add
sglTop = 25
sglLeft = 25
With wks
lngLastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
varData = .Range("A1", .Cells(lngLastRow, "P")).Value
End With
For lngRow = 2 To lngLastRow
' load data into array
strClass = varData(lngRow, 8)
With objClassData(1)
.ClassName = strClass
.GradeData(1, 1) = varData(lngRow, 9)
.GradeData(1, 2) = varData(lngRow, 10)
.GradeData(1, 3) = varData(lngRow, 11)
.FillColour(1) = 10
.FillColour(2) = 11
.FillColour(3) = 12
End With
Select Case varData(lngRow, 7)
Case "HP"
objClassData(1).GradeData(2, 1) = varData(lngRow, 9)
Case "H"
objClassData(1).GradeData(2, 2) = varData(lngRow, 10)
Case "P"
objClassData(1).GradeData(2, 3) = varData(lngRow, 11)
End Select
CreateChart objClassData(1), wksCharts, sglTop, sglLeft
sglLeft = sglLeft + mc_sglWIDTH + mc_sglGAP
Erase objClassData
Next lngRow
Application.ScreenUpdating = True
End Sub
Sub CreateChart(objData As ClassData, _
wksTarget As Worksheet, _
sglTop As Single, _
sglLeft As Single)
Dim objChtObj As ChartObject
Dim cht As Chart
Dim ser As Series
Dim lngRow As Long
Dim lngCol As Long
With wksTarget
Set objChtObj = .ChartObjects.Add(sglLeft, sglTop, mc_sglWIDTH, mc_sglHEIGHT)
Set cht = objChtObj.Chart
With cht
.ChartType = xlColumnStacked
For lngRow = 1 To 2
Set ser = .SeriesCollection.NewSeries
With ser
.Values = Application.Index(objData.GradeData, lngRow, 0)
.XValues = Array("HP", "H", "P")
' for main data, just colour points
If lngRow = 1 Then
For lngCol = 1 To 3
ser.Points(lngCol).Interior.ColorIndex = objData.FillColour(lngCol) - 7
Next lngCol
Else
' for arrow data, add arrow and colour
For lngCol = 1 To 3
AddArrowToPoint ser.Points(lngCol), objData.FillColour(lngCol)
Next lngCol
End If
End With
Next lngRow
' set gap width
.ChartGroups(1).GapWidth = 0
.HasLegend = False
' add title using class name
.HasTitle = True
With .ChartTitle
.Text = objData.ClassName
.AutoScaleFont = False
.Font.Size = 9
End With
End With
End With
End Sub
Sub AddArrowToPoint(pt As Point, lngSchemeColour As Long)
Dim shpArrow As Shape
Set shpArrow = ActiveSheet.Shapes.AddShape(msoShapeDownArrow, 92.25, 191.25, 30.75, 27.75)
With shpArrow
With .Fill
.Visible = msoTrue
.Solid
.ForeColor.SchemeColor = lngSchemeColour
.Transparency = 0#
End With
With .Line
.Weight = 0.75
.DashStyle = msoLineSolid
.Style = msoLineSingle
.Transparency = 0#
.Visible = msoTrue
.ForeColor.SchemeColor = 64
.BackColor.RGB = RGB(255, 255, 255)
End With
.CopyPicture
pt.Paste
End With
Application.CutCopyMode = False
shpArrow.Delete
End Sub
|
