Showing posts with label Getting descripting statistics on varying number of groups with varying number of rows without data analysis toolpack using VBA. Show all posts
Showing posts with label Getting descripting statistics on varying number of groups with varying number of rows without data analysis toolpack using VBA. Show all posts

Sunday, February 24, 2019

Getting descripting statistics on varying number of groups with varying number of rows without data analysis toolpack using VBA


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