Categorized | excel chart, excel macro and vba, six sigma

Control Chart in Excel Using VBA – Six Sigma Control Chart Code & Software

In Six Sigma Control charts using Excel we saw how to make control charts using named ranges. From there on, it was a short hop to porting the logic to VBA. So here is the VBA code for automating the creation of a six sigma control charts. It has been tested with Excel 2000, Excel 2007 and Excel 2010.

How to Use the Control Chart Program

1. Simply click the ‘Make Control Chart’ button.

2. Using the form that appears, select the range that contains the (numeric) data points for the control chart.

3. Again, using the second form, select the range that contains the labels for the control chart. If no labels are available, press escape (‘esc’)

4. Congratulations. You can now bask in the glow of the six sigma control chart 🙂

Chart Code

Here are the code snippets but if you are interested in the download, you can get it (as usual) at the bottom of this post.

Get Range Using VBA

The first step is to get a range (first for data set and then for the labels) for making the control chart using VBA.

1
2
3
4
5

Public Function GetRange(box_message As String) As Range
Set GetRange = Nothing
On Error Resume Next
Set GetRange = Application.InputBox(box_message, "Select Range", Selection.Address, , , , , 8)
End Function

Check if the Range Provided Meets Requirements

We need to ensure that the range provided meets the data set assumptions. In our case, we assume that the data for the control chart will be provided as a single column.

1
2
3
4
5
6
7

Public Function IsNotOk(ByVal rng As Range) As Boolean 'TO CHECK IF A GIVEN RANGE IS BLANK
IsNotOk = True
On Error GoTo if_error_occured:
If rng.Rows.Count > 0 And rng.Columns.Count = 1 Then IsNotOk = False
if_error_occured:
If Err.Number Then IsNotOk = True
End Function

Check If Each Cell in Data Set Contains Numeric Values

To ensure that the data provided is all numeric, we check each cell. Without this check in place If the user provides non-numeric data as input, the control chart will go bust

1
2
3
4
5
6
7

Public Function check_if_numeric(rng As Range) As Boolean
Dim cel As Range
check_if_numeric = True
For Each cel In rng.Cells
If Not (Application.WorksheetFunction.IsNumber(cel.Value)) Then check_if_numeric = False
Next cel
End Function

Make Control Chart Using VBA

Once we have both the data and the label ranges, its time to create the chart. Note that we have made use of the named ranges to add the upper and the lower control limits.

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
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260

Sub make_control_chart()
Dim data_values As Range
Dim chart_labels As Range
Dim range_selected_before As Range
Dim got_label_range As Boolean
Dim got_value_range As Boolean
Dim bActivate As Boolean
Dim myChtObj As ChartObject
Dim plot_series, MyNewSrs As Series
Dim series_label As String
Dim number_of_control_limits As Integer
Dim standard_deviation As Integer
Dim data_str As String
Dim avg_str As String

On Error GoTo if_error_occured: 'GOTO THE END OF THE PROGRAM

'GET RANGE FOR DATA VALUES
bActivate = False ' True to re-activate the input range
Set data_values = GetRange("Please select the range containing the DATA POINTS" & Chr(13) & "(press select a single column)")
If IsNotOk(data_values) Then
MsgBox "Incorrect Input Data !"
End
ElseIf Not (check_if_numeric(data_values)) Then
MsgBox "Incorrect Input Data !"
End
End If

'GET RANGE FOR CHART X-AXIS LABELS
got_label_range = True ' True to re-activate the input range
Set chart_labels = GetRange("Please select the range containing the LABELS" & Chr(13) & "(press ESC if no labels available)")
If IsNotOk(chart_labels) Then
got_label_range = False
End If

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

'LETS CREATE THE CHART NOW
Set myChtObj = ActiveSheet.ChartObjects.Add(Left:=100, Width:=400, Top:=25, Height:=300)
myChtObj.Chart.ChartType = xlLineMarkers

'REMOVE ALL UNWANTED SERIES FROM CHART, IF ANY
For Each MyNewSrs In myChtObj.Chart.SeriesCollection ' myChtObj.Chart.SeriesCollection
MyNewSrs.Delete
Next MyNewSrs
Set MyNewSrs = Nothing

If got_label_range Then 'IF WE HAVE THE LABEL RANGE
'ADD NEW SERIES
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = "PLOT"
.Values = data_values
.XValues = chart_labels
End With
Else
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = "PLOT"
.Values = data_values
End With
End If

'FORMAT THE PLOT SERIES
Set plot_series = MyNewSrs
With MyNewSrs
.Border.ColorIndex = 1
.MarkerBackgroundColorIndex = 2
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlCircle
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
Set MyNewSrs = Nothing

'CREATE NAMED RANGE FOR THE DATA VALUES, AVERAGE, LOWER AND UPPER CONTROL LIMITS
data_str = Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values"
avg_str = "roundup(average(" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values" & "),2)"

ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_data_values", RefersToR1C1:=data_values
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_AVG", RefersToR1C1:="=" & avg_str & ""
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL1", RefersToR1C1:="=" & avg_str & "- roundup(1*stdev(" & data_str & "),2)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL2", RefersToR1C1:="=" & avg_str & "- roundup(2*stdev(" & data_str & "),2)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_LCL3", RefersToR1C1:="=" & avg_str & "- roundup(3*stdev(" & data_str & "),2)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL1", RefersToR1C1:="=" & avg_str & "+ roundup(1*stdev(" & data_str & "),2)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL2", RefersToR1C1:="=" & avg_str & "+ roundup(2*stdev(" & data_str & "),2)"
ActiveWorkbook.Names.Add Name:=Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_UCL3", RefersToR1C1:="=" & avg_str & "+ roundup(3*stdev(" & data_str & "),2)"

'ADD THE LINE FOR AVERAGE
Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries

With MyNewSrs
.Name = "AVG = "
.Values = "='" & ActiveSheet.Name & "'!" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_AVG"
.ChartType = xlXYScatter
'.ErrorBar Direction:=xlX, Include:=xlNone, Type:=xlFixedValue, Amount:=10000
'.ErrorBar Direction:=xlX, Include:=xlUp, Type:=xlFixedValue, Amount:=20
.ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count
.MarkerBackgroundColorIndex = xlAutomatic
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlNone
.Smooth = False
.MarkerSize = 5
.Shadow = False
With .Border
.Weight = xlHairline
.LineStyle = xlNone
End With
'With .ErrorBars.Border
' .LineStyle = xlContinuous
' .ColorIndex = 3
' .Weight = xlThin
'End With
End With

Set MyNewSrs = Nothing

'ADD UPPER AND LOWER CONTROL LIMITS
For number_of_control_limits = 1 To 3
For standard_deviation = -1 To 1 Step 2

Select Case standard_deviation:
Case -1: series_label = "LCL"
Case 1: series_label = "UCL"
End Select

Set MyNewSrs = myChtObj.Chart.SeriesCollection.NewSeries
With MyNewSrs
.Name = series_label & number_of_control_limits & " ="
.Values = "='" & ActiveSheet.Name & "'!" & Application.WorksheetFunction.Substitute(myChtObj.Name, " ", "") & "_" & series_label & number_of_control_limits
.ChartType = xlXYScatter
.ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count
End With

MyNewSrs.ErrorBar Direction:=xlX, Include:=xlPlusValues, Type:=xlFixedValue, Amount:=data_values.Rows.Count

Select Case number_of_control_limits:
Case 1:
With MyNewSrs.ErrorBars.Border
.LineStyle = xlGray25
.ColorIndex = 15
.Weight = xlHairline
End With
Case 2:
With MyNewSrs.ErrorBars.Border
.LineStyle = xlGray25
.ColorIndex = 57
.Weight = xlHairline
End With
Case 3:
With MyNewSrs.ErrorBars.Border
.LineStyle = xlGray75
.ColorIndex = 3
.Weight = xlHairline
End With
End Select

MyNewSrs.ErrorBars.EndStyle = xlNoCap

With MyNewSrs
With .Border
.Weight = xlHairline
.LineStyle = xlNone
End With
.MarkerBackgroundColorIndex = xlAutomatic
.MarkerForegroundColorIndex = xlAutomatic
.MarkerStyle = xlNone
.Smooth = False
.MarkerSize = 5
.Shadow = False
End With
Set MyNewSrs = Nothing
Next standard_deviation
Next number_of_control_limits

myChtObj.Chart.ApplyDataLabels AutoText:=True, LegendKey:=False, _
HasLeaderLines:=False, ShowSeriesName:=True, ShowCategoryName:=False, _
ShowValue:=True, ShowPercentage:=False, ShowBubbleSize:=False, Separator:=" "

'OFFSET THE LABELS
For Each MyNewSrs In myChtObj.Chart.SeriesCollection
With MyNewSrs.Points(1).DataLabel
.Left = 400
End With
Next MyNewSrs

'LETS FORMAT THE CHART
With myChtObj
With .Chart.Axes(xlCategory)
.MajorTickMark = xlNone
.MinorTickMark = xlNone
.TickLabelPosition = xlNextToAxis
End With
With .Chart.Axes(xlValue)
.MajorTickMark = xlOutside
.MinorTickMark = xlNone
.TickLabelPosition = xlNextToAxis
End With
With .Chart.ChartArea.Border
.Weight = 1
.LineStyle = 0
End With
With .Chart.PlotArea.Border
.ColorIndex = 1
.Weight = xlThin
.LineStyle = xlContinuous
End With
With .Chart.PlotArea.Interior
.ColorIndex = 2
.PatternColorIndex = 1
.Pattern = xlSolid
End With
With .Chart.ChartArea.Font
.Name = "Arial"
.Size = 8
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.Background = xlAutomatic
End With
With .Chart
.HasTitle = False
.Axes(xlCategory, xlPrimary).HasTitle = False
.Axes(xlValue, xlPrimary).HasTitle = True
.HasTitle = True
.ChartTitle.Characters.Text = "Control Chart"
.ChartTitle.Left = 134
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Observations"
End With
With .Chart.Axes(xlCategory).TickLabels
.Alignment = xlCenter
.Offset = 100
.ReadingOrder = xlContext
.Orientation = xlHorizontal
End With
End With

myChtObj.Chart.Legend.Delete
myChtObj.Chart.PlotArea.Width = 310
myChtObj.Chart.Axes(xlValue).MajorGridlines.Delete
myChtObj.Chart.Axes(xlValue).CrossesAt = myChtObj.Chart.Axes(xlValue).MinimumScale
myChtObj.Chart.ChartArea.Interior.ColorIndex = xlAutomatic
myChtObj.Chart.ChartArea.AutoScaleFont = True

'DELETE THE LABELS FOR THE ACTUAL DATA SERIES
plot_series.DataLabels.Delete
Set plot_series = Nothing

if_error_occured:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
If Err.Number Then z_delete_all_named_range

End Sub

Clean Up If the VBA Code Does Not Succeed

If the code breaks down in the middle, its important to clean up the mess. So we remove any unused named ranges, turn on automatic calculation. In its present form, this code removes all named ranges from the workbook. You may want to modify this a bit to ensure that this code deletes only the named ranges that pertain to the most recent chart.

1
2
3
4
5
6
7
8

Sub z_delete_all_named_range()
Dim nam As Name
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
For Each nam In ActiveWorkbook.Names
nam.Delete
Next nam
End Sub

You can download the excel control chart utility here or click on the button below:

You may want to also try out the Control Chart Utility for Excel. The utility makes the process a lot easier.

The product is shipped as an Excel add-in (.xla). The treemap option is accessible as a menu option in Excel 2003 and earlier and as a new ribbon tab in Excel 2007 and later.

Excel Chart Maximum Y Axis Value and Axis Interval (Major Unit)

Prevent Users Ctrl Break (ing) Your VBA Code During Execution

Cricketing Heat Map

Multiple Scale Chart – Adding Customized Scale to Each Category in a Chart

Multithreaded VBA – An Approach To Processing Using VBScript

Volatility Chart in Excel – Lessons in Chart Design From NY Times

What Do You Think ?

Comments and Trackbacks

JP wrote:

In GetRange, you declare SelectedRangeForValues as a Variant. Shouldn’t it be a Range Object?

December 16th, 2009 at 8:52 am
Ajay wrote:

@JP – The decision to hive off the getrange part into a function was a last minute one. I was earlier using it twice, once to get the data range and then the labels. Actually both the variables declared on that line thus became redundant and have now been removed 🙂 Thanks a ton.
Regards,

December 16th, 2009 at 12:55 pm
Dan Kenkel wrote:

This is an amazing website, so much content here about Excel tips and VBA. I will be visiting often as I have been working on many similar projects.

June 3rd, 2011 at 4:28 pm
Denis J. wrote:

I agree Dan. Great site, I am using it two years now and each time I needed a solution, I found it here. TOP DRAWER stuff

June 6th, 2011 at 7:25 pm
Dan wrote:

In the “z_delete_all_named_range” routine I’m getting a run-time error for an invalid name on the “nam.Delete” line.

Has anybody else seen this?

March 31st, 2014 at 10:54 am