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

No comments:

Post a Comment