Tuesday, March 19, 2019

Automating calculation of Process Capability,CP,CPK,PPM using Six Sigma using VBA ,VBA Teacher Sourav,Kolkata 08910141720

Sub process_capability_macro()


 With Application
        .ScreenUpdating = False
        .DisplayAlerts = False
        .EnableEvents = False
    End With

Dim lRow As Long
Dim lCol As Long
Dim area As String
Dim averageval, stddevval, upper, lower As Double


Sheets("process_capability").Select

'a little housekeeping

    Range("B16").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("D16").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("E16").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("F16").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("G16").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
    Range("H16").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.ClearContents
   
   'let us begin
  
   Sheets("process_capability").Select


Dim address As String
address = "C16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    area = GetText(address) & 16 & ":" & GetText(address) & lRow
    Range("C2").Select
    ActiveCell.Value = "UTL(Upper Tolerance Limit)"
    Range("B2").Select
    ActiveCell.Value = 92
    Range("C3").Select
    ActiveCell.Value = "LTL(Lower Tolerance Limit)"
   Range("B3").Select
    ActiveCell.Value = 89.5
    Range("C4").Select
     ActiveCell.Value = "µ(Arithmatic Mean)"
        averageval = Application.WorksheetFunction.average(Range(area))
       Range("B4").Select
       ActiveCell.Value = averageval
       Range("C5").Select
       ActiveCell.Value = "(StandardDeviation Of A Sample)"

       Range("B5").Select
      
      ' ActiveCell.Formula = "=FIND(""$""," & """" & s & """" & ")"
       
      ' ActiveCell.Formula = "=STDEVA(" & (area) & ") "
    ' ActiveCell.Formula = "=STDEVA( " & area & ")"
   
     ActiveCell.Formula = "=STDEVA(" & Range(area).address & ")"
    
     stddevval = ActiveCell.Value
    
     Range("C6").Select
       ActiveCell.Value = "Upper Six-Sigma-Limit"
        Range("B6").Select
        ActiveCell.Value = averageval + (6 * stddevval)
     
       
       
      Range("C7").Select
       ActiveCell.Value = "Lower Six-Sigma-Limit"
        Range("B7").Select
        ActiveCell.Value = averageval - (6 * stddevval)
        lower = averageval - (6 * stddevval)
       Range("B15").Select
       ActiveCell.Value = "Bins"
       ActiveCell.Offset(1, 0).Select
      
     
      ' MsgBox (lower)
       Dim temp As Double
       temp = (averageval - (6 * stddevval)) - 1
      While temp < ((averageval + (6 * stddevval)) + 1)
     
       ActiveCell.Value = Round(temp, 2)
       temp = temp + 0.01
       ActiveCell.Offset(1, 0).Select
       Wend
        Range("D15").Select
       ActiveCell.Value = "Frequency"
       '
      
      
       Dim lRow1 As Long
       Dim lRow2 As Long
      
       address = "C16"
      lRow1 = Range(address).End(xlDown).Row
      address = "B16"
      lRow2 = Range(address).End(xlDown).Row
    area = "D16:D" & lRow2
    Range(area).Select
       Selection.FormulaArray = "=FREQUENCY(RC[-1]:R" & (lRow1) & "C[-1],RC[-2]:R" & (lRow2) & "C[-2])"
      
       'creating new sheet
      
        Dim newSheetName As String
    Dim checkSheetName As String
    'newSheetName = Application.InputBox("Input Sheet Name:", "Kutools for Excel", _
                                    "sheet4", , , , , 2)
    newSheetName = "Chart"
                                   
    On Error Resume Next
    checkSheetName = Worksheets(newSheetName).Name
    If checkSheetName = "" Then
       ' Worksheets.Add.Name = newSheetName
       ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = newSheetName
        
    Else
   
    Worksheets(newSheetName).Delete
   
         ActiveWorkbook.Sheets.Add(After:=Sheets(Sheets.Count)).Name = newSheetName
    End If
    'Creating the 2d column chart otherwise known as column clustered chart
   
'    Dim co As ChartObject
'    Dim ct As Chart
'    Dim scl As SeriesCollection
'    Dim ser1 As Series
'    Dim chartname As String
'
'    Sheets("process_capability").Select
'
'       Set co = Worksheets("process_capability").ChartObjects.Add(Range("P2").Left, Range("P2").Top, 700, 300)
'       chartname = Worksheets("process_capability").Range("D15").Value
'       co.Name = chartname
'      ' MsgBox (co.Name)
'       Set ct = co.Chart
'       With ct
'       .HasLegend = True
'       .HasTitle = True
'       .ChartTitle.Text = "Frequency"
'       Set sc1 = .SeriesCollection
'       Set ser1 = sc1.NewSeries
'       With ser1
'       .Name = Range("D15").Value
'       .XValues = Range(Range("B15").Offset(1, 0), Range("B15").End(xlDown))
'       .Values = Range(Range("D15").Offset(1, 0), Range("D15").End(xlDown))
'       .ChartType = xlColumnClustered
'
'       End With
'
'
'       End With
      
'create 2d frequency chart

Call createfrequencychart

'Probability mass function calculation

Sheets("process_capability").Select

Range("E15").Select
       ActiveCell.Value = "Probability Mass Function"
       '
      

      
       address = "B16"
      lRow1 = Range(address).End(xlDown).Row
      'MsgBox (lRow1)
     
    area = "E16:E" & lRow1
    Range(area).Select
        Selection.FormulaArray = "=NORM.DIST(RC[-3]:R" & (lRow1) & "C[-3],R[-12]C[-3],R[-11]C[-3],FALSE)"

'now we have add the probability mass function data with respect to beans in our chart

Call modchart

'Cumulative distribution function

 'Range("F16:F35").Select
  '  Selection.FormulaArray = "=NORM.DIST(RC[-4]:R[19]C[-4],R[-12]C[-4],R[-11]C[-4],TRUE)"
  Sheets("process_capability").Select

Range("F15").Select
       ActiveCell.Value = "Cumulative Distribution Function"
       '
      

      
       address = "B16"
      lRow1 = Range(address).End(xlDown).Row
      'MsgBox (lRow1)
     
    area = "F16:F" & lRow1
    Range(area).Select
        Selection.FormulaArray = "=NORM.DIST(RC[-4]:R" & (lRow1) & "C[-4],R[-12]C[-4],R[-11]C[-4],TRUE)"
        'Selection.FormulaArray = "=NORM.DIST(RC[-4]:R[19]C[-4],R[-12]C[-4],R[-11]C[-4],TRUE)"


'Let us add an second chart on cumulative distribution function on Chart sheet which will be a line chart
Call secondchart

'Maximum vertical axis or maximum frequency value

Sheets("process_capability").Select

Dim maximum As Double

 address = "D16"


 lRow = Range("D16").End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    area = GetText(address) & 16 & ":" & GetText(address) & lRow
   
    maximum = Application.max(Range(area))
    Range("C8").Select
    ActiveCell.Value = "Maximum Vertical Axis"
   
    Range("B8").Select
    ActiveCell.Value = maximum
   
'Six sigma limits
Sheets("process_capability").Select
 Range("G15").Select
    ActiveCell.FormulaR1C1 = "Six Sigma Limits"
   
    address = "G16"


 lRow = Range("B16").End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    area = GetText(address) & 16 & ":" & GetText(address) & lRow
    'MsgBox (area)
    Range("G16").Select
    ActiveCell.FormulaR1C1 = "=IF(RC[-5]=ROUND(R6C2,2),R8C2,IF(RC[-5]=ROUND(R7C2,2),R8C2,0))"
    Range("G16").Select
    Selection.AutoFill Destination:=Range(area)
   
    'sig sigma limits should be incorporated in our first chart
   
    Call modchart2
   
   
    'Tolerance Limits
   
    Sheets("process_capability").Select
 Range("H15").Select
    ActiveCell.FormulaR1C1 = "Tolerance Limits"
   
    address = "H16"


 lRow = Range("B16").End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    area = GetText(address) & 16 & ":" & GetText(address) & lRow
    'MsgBox (area)
    Range("H16").Select
    'ActiveCell.FormulaR1C1 = "=IF(RC[-6]=ROUND(R6C2,2),R8C2,IF(RC[-5]=ROUND(R7C2,2),R8C2,0))"
     ActiveCell.FormulaR1C1 = "=IF(RC[-6]=ROUND(R2C2,2),R8C2,IF(RC[-6]=ROUND(R3C2,2),R8C2,0))"
    Range("H16").Select
    Selection.AutoFill Destination:=Range(area)
    'Tolerance limits should be incorporated in our first chart
    Call modchart3
   
    'last calculations
    Sheets("process_capability").Select
   
     lRow = Range("B16").End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
   ' MsgBox (lRow)
   
      Range("C9").Select
    ActiveCell.FormulaR1C1 = "CPK(Process Capability Index)"
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "CP(Maximum Possible Process Capability)"
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "Parts within the tolerance limits in one million manufactured parts"
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "PPM(parts outside the tolerance limits in one million manufactured parts )"
    ActiveCell.Offset(-3, -1).Select
    ActiveCell.FormulaR1C1 = "=MIN(R[-7]C-R[-5]C,R[-5]C-R[-6]C)/(3*R[-4]C)"
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=(R[-8]C-R[-7]C)/(6*R[-5]C)"
    ActiveCell.Offset(1, 0).Select
 
    address = Replace(ActiveCell.address, "$", "")
    'Dim LArray() As String
   ' LArray = Split(address, ":")
    'MsgBox (LArray(1))


   
  
    Dim cellnum As Range
    Set cellnum = ActiveCell
      Dim firstval As Double
  Dim secondval As Double
 
  cellnum.Formula = "=VLOOKUP(" & Range("B2").Value & ", 'process_capability'!B16:F" & lRow & ", 5, FALSE)"

  firstval = ActiveCell.Value
  cellnum.Formula = "=VLOOKUP(" & Range("B3").Value & ", 'process_capability'!B16:F" & lRow & ", 5, FALSE)"
  secondval = ActiveCell.Value
  cellnum.Value = (firstval - secondval) * 1000000
    ActiveCell.Offset(1, 0).Select
    ActiveCell.FormulaR1C1 = "=1000000-R[-1]C"
   
    'last makeup of charts
    Call setcharttitle
   
     With Application
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
   
   
End Sub

Function GetText(CellRef As String)
Dim StringLength As Integer
StringLength = Len(CellRef)
For i = 1 To StringLength
If Not (IsNumeric(Mid(CellRef, i, 1))) Then Result = Result & Mid(CellRef, i, 1)
Next i
GetText = Result
End Function
Sub createfrequencychart()



Dim ch As Shape
Dim yvalues As String
Dim xvalues As String
Sheets("process_capability").Select
Dim address As String
address = "D16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    yvalues = GetText(address) & 16 & ":" & GetText(address) & lRow
    'MsgBox (yvalues)
   
    address = "B16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    xvalues = GetText(address) & 16 & ":" & GetText(address) & lRow
    'MsgBox (xvalues)


    Sheets("Chart").Select
    ActiveSheet.Shapes.AddChart2(201, xlColumnClustered).Select
     Set ch = ActiveSheet.Shapes(1)
    ch.Name = "Chartprocess"
   
    ch.IncrementLeft -266.25
   ch.IncrementTop -87.75
    ch.ScaleWidth 2.6625, msoFalse, msoScaleFromTopLeft
    ch.ScaleHeight 1.4531251823, msoFalse, msoScaleFromTopLeft
    ch.Select
   
    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.FullSeriesCollection(1).Name = "=process_capability!$D$15"
   
  '  ActiveChart.FullSeriesCollection(1).Values = "=process_capability!$D$16:$D$35"
  ActiveChart.FullSeriesCollection(1).Values = "=process_capability!" & yvalues
    'ActiveChart.FullSeriesCollection(1).xvalues = "=process_capability!$B$16:$B$35"
    ActiveChart.FullSeriesCollection(1).xvalues = "=process_capability!" & xvalues
   
End Sub

Sub modchart()
Sheets("process_capability").Select
Dim yvalues As String
Dim xvalues As String

Dim address As String
address = "E16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    yvalues = GetText(address) & 16 & ":" & GetText(address) & lRow
   ' MsgBox (yvalues)
   
    address = "B16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    xvalues = GetText(address) & 16 & ":" & GetText(address) & lRow
    'MsgBox (xvalues)


Sheets("Chart").Select
Dim ch As Shape
Set ch = ActiveSheet.Shapes(1)
ch.Select


    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.FullSeriesCollection(2).Name = "=process_capability!$E$15"
    'ActiveChart.FullSeriesCollection(2).Values = "=process_capability!$E$16:$E$35"
    ActiveChart.FullSeriesCollection(2).Values = "=process_capability!" & yvalues
   ' ActiveChart.FullSeriesCollection(2).xvalues = "=process_capability!$B$16:$B$35"
   ActiveChart.FullSeriesCollection(2).xvalues = "=process_capability!" & xvalues
  
  
    ActiveChart.PlotArea.Select
    ActiveChart.ChartArea.Select
    ActiveChart.ChartType = xlColumnClustered
    ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
   ' ActiveChart.FullSeriesCollection(1).AxisGroup = 1
    ActiveChart.FullSeriesCollection(2).ChartType = xlLine
    ActiveChart.FullSeriesCollection(1).AxisGroup = 1
 
      ActiveChart.FullSeriesCollection(2).AxisGroup = 2
    ActiveSheet.ChartObjects("Chartprocess").Activate
    ActiveChart.FullSeriesCollection(2).Select
    ActiveChart.FullSeriesCollection(2).Smooth = True
    ActiveChart.Axes(xlValue, xlSecondary).Select
    ActiveChart.Axes(xlValue, xlSecondary).MinimumScale = 0
    ActiveChart.ChartArea.Select

End Sub

Sub secondchart1()
Dim co As ChartObject
    Dim ct As Chart
    Dim scl As SeriesCollection
    Dim ser1 As Series
    Dim chartname As String

    Sheets("Chart").Select

       Set co = Worksheets("Chart").ChartObjects.Add(Range("D30").Left, Range("D30").Top, 900, 300)
      
       'chartname = Worksheets("process_capability").Range("D15").Value
       chartname = "cumulative"
       co.Name = chartname
      ' MsgBox (co.Name)
       Set ct = co.Chart
       With ct
       .HasLegend = True
       .HasTitle = True
       .ChartTitle.Text = Worksheets("process_capability").Range("F15").Value
       Set sc1 = .SeriesCollection
       Set ser1 = sc1.NewSeries
       With ser1
       .Name = Worksheets("process_capability").Range("F15").Value
       .xvalues = Range(Worksheets("process_capability").Range("B15").Offset(1, 0), Worksheets("process_capability").Range("B15").End(xlDown))
       .Values = Range(Worksheets("process_capability").Range("F15").Offset(1, 0), Worksheets("process_capability").Range("F15").End(xlDown))
       .ChartType = xlLine
       .Select
        .Smooth = True
       
       End With
     

       End With
      
       Sheets("Chart").Range("A1").Select
      
      
      
End Sub

Sub modchart2()
Sheets("process_capability").Select
Dim yvalues As String
Dim xvalues As String

Dim address As String
address = "G16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    yvalues = GetText(address) & 16 & ":" & GetText(address) & lRow
   ' MsgBox (yvalues)
   
    address = "B16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    xvalues = GetText(address) & 16 & ":" & GetText(address) & lRow
    'MsgBox (xvalues)


Sheets("Chart").Select
Dim ch As Shape
Set ch = ActiveSheet.Shapes(1)
ch.Select


    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.FullSeriesCollection(3).Name = "=process_capability!$G$15"
    'ActiveChart.FullSeriesCollection(2).Values = "=process_capability!$E$16:$E$35"
    ActiveChart.FullSeriesCollection(3).Values = "=process_capability!" & yvalues
   ' ActiveChart.FullSeriesCollection(2).xvalues = "=process_capability!$B$16:$B$35"
   ActiveChart.FullSeriesCollection(3).xvalues = "=process_capability!" & xvalues
  
  
   ActiveChart.FullSeriesCollection(1).AxisGroup = 1
 
   ActiveChart.FullSeriesCollection(2).AxisGroup = 2
     
   ActiveChart.FullSeriesCollection(3).AxisGroup = 1
     
    ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
    ActiveChart.FullSeriesCollection(2).ChartType = xlLine
     ActiveChart.FullSeriesCollection(3).ChartType = xlColumnClustered
      ActiveChart.FullSeriesCollection(2).Smooth = True
    ActiveChart.Axes(xlValue, xlSecondary).Select
    ActiveChart.Axes(xlValue, xlSecondary).MinimumScale = 0
  

End Sub

Sub secondchart()
Dim co As ChartObject
    Dim ct As Chart
    Dim scl As SeriesCollection
    Dim ser1 As Series
    Dim chartname As String

    Sheets("Chart").Select

       Set co = Worksheets("Chart").ChartObjects.Add(Range("D30").Left, Range("D30").Top, 900, 300)
      
       'chartname = Worksheets("process_capability").Range("D15").Value
       chartname = "cumulative"
       co.Name = chartname
      ' MsgBox (co.Name)
       Set ct = co.Chart
       With ct
       .HasLegend = True
       .HasTitle = True
       .ChartTitle.Text = Worksheets("process_capability").Range("F15").Value
       Set sc1 = .SeriesCollection
       Set ser1 = sc1.NewSeries
       With ser1
       .Name = Worksheets("process_capability").Range("F15").Value
       .xvalues = Range(Worksheets("process_capability").Range("B15").Offset(1, 0), Worksheets("process_capability").Range("B15").End(xlDown))
       .Values = Range(Worksheets("process_capability").Range("F15").Offset(1, 0), Worksheets("process_capability").Range("F15").End(xlDown))
       .ChartType = xlLine
       .Select
        .Smooth = True
       
       End With


       End With
      
       Sheets("Chart").Range("A1").Select
      
End Sub



Sub modchart3()
Sheets("process_capability").Select
Dim yvalues As String
Dim xvalues As String

Dim address As String
address = "H16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    yvalues = GetText(address) & 16 & ":" & GetText(address) & lRow
   ' MsgBox (yvalues)
   
    address = "B16"
  lRow = Range(address).End(xlDown).Row
    If lRow = 1 Then
    lRow = 2
    End If
    xvalues = GetText(address) & 16 & ":" & GetText(address) & lRow
    'MsgBox (xvalues)


Sheets("Chart").Select
Dim ch As Shape
Set ch = ActiveSheet.Shapes(1)
ch.Select


    ActiveChart.SeriesCollection.NewSeries
    ActiveChart.FullSeriesCollection(4).Name = "=process_capability!$H$15"
    'ActiveChart.FullSeriesCollection(2).Values = "=process_capability!$E$16:$E$35"
    ActiveChart.FullSeriesCollection(4).Values = "=process_capability!" & yvalues
   ' ActiveChart.FullSeriesCollection(2).xvalues = "=process_capability!$B$16:$B$35"
   ActiveChart.FullSeriesCollection(4).xvalues = "=process_capability!" & xvalues
  
   ActiveChart.FullSeriesCollection(1).AxisGroup = 1
 
   ActiveChart.FullSeriesCollection(2).AxisGroup = 2
     
   ActiveChart.FullSeriesCollection(3).AxisGroup = 1
  
   ActiveChart.FullSeriesCollection(4).AxisGroup = 1
     
    ActiveChart.FullSeriesCollection(1).ChartType = xlColumnClustered
    ActiveChart.FullSeriesCollection(2).ChartType = xlLine
     ActiveChart.FullSeriesCollection(3).ChartType = xlColumnClustered
      ActiveChart.FullSeriesCollection(4).ChartType = xlColumnClustered
      ActiveChart.FullSeriesCollection(2).Smooth = True
    ActiveChart.Axes(xlValue, xlSecondary).Select
    ActiveChart.Axes(xlValue, xlSecondary).MinimumScale = 0
  
  

End Sub



Sub setcharttitle()
Sheets("Chart").Select
Dim co As ChartObject
Dim ct As Chart
Set co = ActiveSheet.ChartObjects("Chartprocess")
Set ct = co.Chart


With ct
'X axis name
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "Values(mm)"
'y-axis name
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "Frequency(pieces)"
'secondary axis
.Axes(xlValue, xlSecondary).HasTitle = True
.Axes(xlValue, xlSecondary).AxisTitle.Characters.Text = "Probability Mass Function"

End With

Sheets("Chart").Range("A1").Select
Sheets("process_capability").Select


End Sub

Function GetNumeric(CellRef As String)
Dim StringLength As Integer
StringLength = Len(CellRef)
For i = 1 To StringLength
If IsNumeric(Mid(CellRef, i, 1)) Then Result = Result & Mid(CellRef, i, 1)
Next i
GetNumeric = Result
End Function

No comments:

Post a Comment