Sub descriptiveanal()
'Finds the last non-blank cell in a single row or column
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
End With
Dim lRow As Long
Dim lCol As Long
Dim ColumnLetter As String
Dim area As String
Dim pasteloc As String
Sheets("descr").Select
'Find the last non-blank cell in column A(1)
lRow = Cells(1, 1).End(xlDown).Row
If lRow = 1 Then
lRow = 2
End If
'Find the last non-blank cell in row 1
lCol = Cells(1, 1).End(xlToRight).Column
ColumnLetter = Split(Cells(1, lCol).address, "$")(1)
' MsgBox ColumnLetter & lRow
area = "A1:" & ColumnLetter & lRow
lCol = lCol + 2
ColumnLetter = Split(Cells(1, lCol).address, "$")(1)
pasteloc = ColumnLetter & 1
'MsgBox (pasteloc)
'MsgBox (area)
Range(area).Select
Application.SendKeys "{ENTER}"
Application.Run "ATPVBAEN.XLAM!Descr", ActiveSheet.Range(" " & area & " "), ActiveSheet.Range(" " & pasteloc & " "), "C", True, True, 1, 1, 95
'this is more calculation
Dim uslval As Double
Dim lslsval As Double
uslval = InputBox("enter value for usl")
lslval = InputBox("enter value for usl")
Dim i As Integer
i = 1
Dim address As String
address = "A1"
Sheets("descr").Select
Range(address).Select
While ActiveCell.Value <> ""
Range(address).Select
'Range("A1").Select
Dim k As Long
Dim minimum As Double
Dim quartile1, quartile2, quartile3 As Double
Dim max As Double
Dim averageval As Double
Dim stddevval As Double
Dim varcoef As Double
k = ActiveSheet.Range(address, ActiveSheet.Range(address).End(xlDown)).Rows.Count
lRow = Cells(1, i).End(xlDown).Row
If lRow = 1 Then
lRow = 2
End If
area = GetText(address) & 2 & ":" & GetText(address) & lRow
' MsgBox (area)
minimum = Application.min(Range(area))
'MsgBox (minimum)
quartile1 = Application.WorksheetFunction.Quartile(Range(area), 1)
quartile2 = Application.WorksheetFunction.Quartile(Range(area), 2)
quartile3 = Application.WorksheetFunction.Quartile(Range(area), 3)
max = Application.min(Range(area))
averageval = Application.WorksheetFunction.average(Range(area))
stddevval = Application.WorksheetFunction.StDev(Range(area))
area = GetText(address) & (lRow + 2)
' MsgBox (area)
Range(area).Select
ActiveCell.Value = "Count"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = k
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Minimum Value"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = minimum
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Quartile 1"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = quartile1
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Quartile 2"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = quartile2
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Quartile 3"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = quartile3
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Maximum Value"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = max
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Average"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = averageval
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Standard Deviation"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = stddevval
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Variation Coefficient"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = (stddevval / averageval) * 100
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "USL"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = uslval
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "LSL"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = lslval
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Cp"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = (uslval - lslval) / (6 * stddevval)
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Cpl"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = (averageval - lslval) / (3 * stddevval)
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Cpu"
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = (uslval - averageval) / (3 * stddevval)
ActiveCell.Offset(1, 0).Select
ActiveCell.Value = "Cpk"
ActiveCell.Offset(1, 0).Select
Dim cpl As Double
cpl = (averageval - lslval) / (3 * stddevval)
Dim cpu As Double
cpu = (uslval - averageval) / (3 * stddevval)
ActiveCell.Value = Application.min(cpl, cpu)
Range(address).Select
ActiveCell.Offset(0, 1).Select
address = Replace(ActiveCell.address, "$", "")
Range(address).Select
i = i + 1
Wend
ActiveSheet.Cells.Columns.AutoFit
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
No comments:
Post a Comment