• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Excel VBA Code for making Control Chart

J

Jitender Singh Tomar

New Member
Hello All,

I am struggling with a Excel VBA Code for making Chart.

I'm working on below code and wanted to add few more line to this chart.


I will brief about my requirement...I have two columns with Values on which chart is to be build and based on the number of values chart should give Average, Minimum Value, Maximum Value and UCL (Upper Control limit) and Lower Control Limit (LCL).


this below code gives me Avg and LCL, UCL but not min and max and also UCL, LCL is required for level 3 only not for each level.


if anybody could help me to modify this code please.


Thanks a ton.


Code: 
 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:
 
  '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



Moved to VBA Macros
 
Last edited by a moderator:
You must log in or register to reply here.
Back
Top