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
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