Visual Basic for Applications/Get Array Data Stats

Summary

This VBA code module is intended for MS Excel, since it prints a basic set of statistics onto the worksheet. It assumes that there is well behaved numerical data in a 1D array as an input. A frequency distribution is produced and associated statistics for the set.

Notes on the code

• Copy the entire code listing into an Excel Standard module, save it, then run the top procedure.

VBA Code MOdule

Option Explicit
Option Base 1 'important

Private Sub testMakeBinsAndStatsFromArray()
    'Run this to test making of frequency
    'distribution and stats from arrays
    'THIS SUB CLEARS AND WRITES TO SHEET1
    
    Dim vArr As Variant, vBins As Variant
    
    'load a typical 1D data array
    vArr = Array(0, 0.125, 1, 5, 5, 23, 5.1, 5, 10, 10.05, 15, 15.01, 7.3, 16, 15, 0, 3)
    
    'load a typical 1D interval array
    'numbers are upper-limit-inclusive,
    'from previous-limit-exclusive
    vBins = Array(5, 10, 15, 20)
    
    BinStatsOfArrayData vArr, vBins, "Test"

    'report end
    MsgBox "Display done."

End Sub

Private Sub BinStatsOfArrayData(vI As Variant, vB As Variant, Optional sLabel As String = "")
    'Gets the basic stats for a 1D array of numbers.
    'Bin width is provided by an array in vB.
    'Results to the worksheet. Displays frequency
    'distribution, average, median, mode, minimum,
    'maximum, standard deviation, and variance.
    'THIS SUB CLEARS AND WRITES TO SHEET1
    
    Dim vR As Variant, vD As Variant
    Dim n As Long, bOK As Boolean
    Dim LB As Long, UB As Long, LBI As Long, UBI As Long
    
    LBI = LBound(vI, 1): UBI = UBound(vI, 1)
    
    bOK = FreqDist(vI, vB, vR)
    
    LB = LBound(vR, 1): UB = UBound(vR, 1)
    ReDim vD(LB To UB + 12, 1 To 3)
    
    If bOK Then 'load a display array
        'set labels and headings
        vD(1, 1) = sLabel: vD(1, 2) = "Value": vD(1, 3) = "Quantity"
        
        'frequency distribution display
        For n = LB To UB
            If n = LB Then                'first bin
                vD(n + 2, 2) = "<=" & vB(n)                      'bin size
                vD(n + 2, 3) = vR(n, 1)                           'quantity
            ElseIf n > LB And n < UB Then 'middle bins
                vD(n + 2, 2) = ">" & vB(n - 1) & " and <=" & vB(n) 'bin size
                vD(n + 2, 3) = vR(n, 1)                           'quantity
            ElseIf n = UB Then            'last bin
                vD(n + 2, 2) = ">" & vB(n - 1)                    'bin size
                vD(n + 2, 3) = vR(n, 1)                           'quantity
            End If
            vD(n + 2, 1) = "Bin # " & n 'headings
        Next n
        'get various other stats estimates for display
        On Error Resume Next 'avoids Mode() error when no value stands out
        With Application.WorksheetFunction
            vD(UB + 4, 1) = "Average": vD(UB + 4, 3) = Format(.Average(vI), "#0.000")
            vD(UB + 5, 1) = "Median": vD(UB + 5, 3) = .Median(vI)
            vD(UB + 6, 1) = "Mode": vD(UB + 6, 3) = .Mode(vI)
            vD(UB + 7, 1) = "Minimum": vD(UB + 7, 3) = .Min(vI)
            vD(UB + 8, 1) = "Maximum": vD(UB + 8, 3) = .Max(vI)
            vD(UB + 9, 1) = "Std.Deviation": vD(UB + 9, 3) = Format(.StDevP(vI), "#0.000")
            vD(UB + 10, 1) = "SD/Average % (CV)": vD(UB + 10, 3) = Format(.StDevP(vI) * 100 / .Average(vI), "#0.000")
            vD(UB + 11, 1) = "Variance": vD(UB + 11, 3) = Format(.VarP(vI), "#0.000")
            vD(UB + 12, 1) = "No. of Samples": vD(UB + 12, 3) = UBound(vI) - LBound(vI) + 1
        End With
        Err.Clear
    Else
        MsgBox "Problems getting bin count - closing"
        Exit Sub
    End If
    
    'output to sheet
    ClearWorksheet "Sheet1", 3        'clear both contents and formats of the worksheet
    Array2DToSheet vD, "Sheet1", 3, 3 'transfer whole array to sheet with top left at row3, col3
    FormatCells "Sheet1"              'apply font and autofit formats to all cells of the worksheet

End Sub

Private Function FreqDist(vData As Variant, vBounds As Variant, vRet As Variant) As Boolean
    'Gets the frequency distribution for data values in vData
    'Returns in vRet based on bin range data in vBounds.
        
    Dim vFD As Variant
    Dim LBD As Long, UBD As Long, LBB As Long, UBB As Long
        
    'get work array bounds
    LBD = LBound(vData): UBD = UBound(vData)     '1D
    LBB = LBound(vBounds): UBB = UBound(vBounds) '1D
    
    ReDim vRet(LBB To UBB + 1) 'one more than bounds
    
    With Application.WorksheetFunction
        'always returns as one-based array!
        vRet = .Frequency(vData, vBounds)
    End With
    
     FreqDist = True

End Function

Private Sub ClearWorksheet(ByVal sSheet As String, Optional ByVal nOpt As Integer = 1)
   'clears worksheet contents, formats, or both
   'but does not remove charts from the worksheet
   'nOpt options: contents=1, formats=2, all=3
      
   Dim oWSht As Worksheet
   Set oWSht = ThisWorkbook.Worksheets(sSheet)
   oWSht.Activate
   
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
            .ClearContents
        Case 2 'formats only
            .ClearFormats
        Case 3 'formats and contents
            .Clear
    Case Else
        MsgBox "Illegal option in ClearWorksheet - closing"
        Exit Sub
    End Select
   End With
   
   oWSht.Cells(1, 1).Select

End Sub

Private Sub Array2DToSheet(ByVal vIn As Variant, sShtName As String, nStartRow As Long, nStartCol As Long)
    ' transfers contents of input 2D array to specified worksheet positions
    ' Works for any array bounds
    
    Dim oSht As Worksheet, rTarget As Range
    Dim nRows As Long, nCols As Long
    Dim nNewEndC As Long, nNewEndR As Long
    
    'get reference to sheet for output
    Set oSht = ActiveWorkbook.Worksheets(sShtName)

    'get the pre-shift end points
    nRows = UBound(vIn, 1) - LBound(vIn, 1) + 1
    nCols = UBound(vIn, 2) - LBound(vIn, 2) + 1
    
    'modify end point for parameter starting values
    nNewEndR = nRows + nStartRow - 1
    nNewEndC = nCols + nStartCol - 1
       
    ' define the sheet range for the array contents
    Set rTarget = oSht.Range(oSht.Cells(nStartRow, nStartCol), oSht.Cells(nNewEndR, nNewEndC))
    
    'transfer the array contents to the sheet range
    rTarget.Value = vIn

End Sub

Private Sub FormatCells(sSht As String)
    ' Applies certain formats to all cells
    ' of the named parameter worksheet
    
    Dim oSht As Worksheet
    
    Set oSht = ThisWorkbook.Worksheets(sSht)
    oSht.Activate
    
    'format all cells of the worksheet
    oSht.Cells.Select
    With Selection
        .Font.Name = "Consolas" 'mono
        .Font.Size = 20
        .Columns.AutoFit
        .Rows.AutoFit
        .HorizontalAlignment = xlLeft 'xlRight 'xlCenter
        .VerticalAlignment = xlBottom 'xlCenter 'xlTop
    End With
    oSht.Range("A1").Select

End Sub