Visual Basic for Applications/Discrete Data Bin Stats

Summary edit

This code module is intended for MS Excel, since it writes a set of statistics to the worksheet. It assumes that there is discrete data in a 1D array, either string or numeric. A set of statistics is printed, not for the raw data on the array, but for the bin-count of discrete values found on it. It includes a listing of the bin counts and other statistics. For example, if the array contained only elements with a one or a zero value, the results would list the overall counts of each, and produce other statistics.

Notes on the code edit

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

VBA Code Module edit

Option Explicit
Option Base 1

Private Sub testCountUniqueArrayValues()
    'Run this to count unique values,
    'string or numeric, in an array.
    Dim vArr As Variant, nT As Long
    'load a typical 1D data array with test data
    vArr = Array("and", "AND", "And", 7, "C", 5, 8, 3, 5, 6, 7.6, "D", "B", "A", "C", "D")
    'pass array to the proc with label for the display
    CountUniqueArrayValues vArr, 2, 2, "Test Set 1:"

    'report end
    MsgBox "Display done."

End Sub

Private Sub CountUniqueArrayValues(vI As Variant, Optional nRow As Long = 1, _
                                   Optional nCol As Long = 1, Optional sLabel As String = "")
    'Counts instances of unique values in vI. Generates various stats
    'for the bin quantities of each, rather than the array of values themselves.
    Dim vRV As Variant, vRQ As Variant, vDS As Variant
    Dim LB As Long, UB As Long, vDB As Variant
    Dim n As Long, bOK As Boolean
    'make bins and count contents
    bOK = DiscreteItemsCount(vI, vRV, vRQ)
    LB = LBound(vRV, 1): UB = UBound(vRV, 1)
    ReDim vDS(1 To 12, 1 To 3)
    ReDim vDB(LB To UB + 2, 1 To 3)
    If bOK Then 'load bins and stats arrays
        vDB(1, 1) = sLabel: vDB(1, 2) = "Value": vDB(1, 3) = "Quantity"
        For n = LB To UB
             vDB(n + 2, 1) = "Bin # " & n 'headings
             vDB(n + 2, 2) = vRV(n)      'value
             vDB(n + 2, 3) = vRQ(n)      'quantity
        Next n
        On Error Resume Next 'avoids Mode() error when no value stands out
        With Application.WorksheetFunction
            vDS(1, 1) = sLabel: vDS(1, 2) = "": vDS(1, 3) = "Quantity"
            vDS(3, 1) = "Average": vDS(3, 3) = Format(.Average(vRQ), "#0.000")
            vDS(4, 1) = "Median": vDS(4, 3) = .Median(vRQ)
            vDS(5, 1) = "Mode": vDS(5, 3) = .Mode(vRQ)
            vDS(6, 1) = "Minimum": vDS(6, 3) = .Min(vRQ)
            vDS(7, 1) = "Maximum": vDS(7, 3) = .Max(vRQ)
            vDS(8, 1) = "Std.Deviation": vDS(8, 3) = Format(.StDevP(vRQ), "#0.000")
            vDS(9, 1) = "StDev/Av %": vDS(9, 3) = Format(.StDevP(vRQ) * 100 / .Average(vRQ), "#0.000")
            vDS(10, 1) = "Variance": vDS(10, 3) = Format(.VarP(vRQ), "#0.000")
            vDS(11, 1) = "No.Unique Values": vDS(11, 3) = UBound(vRQ) - LBound(vRQ) + 1
            vDS(12, 1) = "No.Samples": vDS(12, 3) = UBound(vI) - LBound(vI) + 1
        End With
        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 vDS, "Sheet1", nRow, nCol          'transfer stats panel to sheet with top left at row3, col3
    If UB <= 65536 Then 'rows limit for excel 2003
        Array2DToSheet vDB, "Sheet1", nRow + 13, nCol 'transfer bins panel to sheet with top left below stats
        MsgBox "To many bins for sheet -closing"
        Exit Sub
    End If
    FormatCells "Sheet1"  'apply font and autofit formats to all cells of the worksheet

End Sub

Private Function DiscreteItemsCount(vIn As Variant, vRetV As Variant, vRetQ As Variant) As Boolean
    'Counts number of repeats of element values found in vIn
    'Returns with one column for each unitque value and quantity found.
    'Returns as 2D vRet, unsorted; row1=input value, row2=item count.

    Dim vA As Variant, vTS As Variant, vTB As Variant
    Dim s As Long, b As Long, n As Long, bFound As Boolean
    Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
    Dim LBS As Long, UBS As Long
    'dimension 2D work array
    ReDim vA(1 To 2, 1 To 1)
    'get source 1D array bounds
    LBS = LBound(vIn): UBS = UBound(vIn)
    'get work array bounds
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
    'intitial values
    s = LBS
    b = 0
    vA(2, 1) = 0
    Do 'step through store
        'get source element value
        vTS = vIn(s)
        'check bins
            b = b + 1
            'get bin element value
            vTB = vA(1, b)
            If vTS = vTB Then 'found in bins
                vA(2, b) = CLng(vA(2, b)) + 1 'update bin
                bFound = True
            End If
        Loop Until b >= UB2 Or bFound = True
        If bFound = False Then 'no such bin exists yet
            'not found in bins
            If vA(2, UB2) <> 0 Then 'first element been used
                ReDim Preserve vA(LB1 To UB1, LB2 To UB2 + 1)
                UB2 = UBound(vA, 2)
            End If
            'update new bin
            vA(1, UB2) = vTS
            vA(2, UB2) = 1
            bFound = True
        End If
        'reset loop variables
        bFound = False
        b = 0
        s = s + 1
    Loop Until s > UBS

    'transfers -need to be separate for other uses
    LB1 = LBound(vA, 1): UB1 = UBound(vA, 1) 'd1 rows
    LB2 = LBound(vA, 2): UB2 = UBound(vA, 2) 'd2 cols
    ReDim vRetV(LB2 To UB2) 'contains values
    ReDim vRetQ(LB2 To UB2) 'contains quantities
    For n = LB2 To UB2
        vRetV(n) = vA(1, n)
        vRetQ(n) = vA(2, n)
    Next n
    For n = LB2 To UB2
        Debug.Print vRetV(n) & vbTab & vRetQ(n)
    Next n
        Debug.Print vbCrLf
   DiscreteItemsCount = 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)
   With oWSht.Cells
    Select Case nOpt
        Case 1 'contents only
        Case 2 'formats only
        Case 3 'formats and contents
    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)
    'format all cells of the worksheet
    With Selection
        .Font.Name = "Consolas" 'mono
        .Font.Size = 20
        .HorizontalAlignment = xlLeft 'xlRight 'xlCenter
        .VerticalAlignment = xlBottom 'xlCenter 'xlTop
    End With

End Sub

See Also edit