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.
In GetRange, you declare SelectedRangeForValues as a Variant. Shouldn’t it be a Range Object?
December 16th, 2009 at 8:52 am@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.
December 16th, 2009 at 12:55 pmRegards,
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 pmI 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 pmIn 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