Visual Basic for Applications/Discrete Data Bin Stats

Summary 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 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 Private Sub testCountUniqueArrayValues() 'Run this to count unique values, 'string or numeric, in an array. 'THIS SUB CLEARS AND WRITES TO SHEET1 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. 'THIS SUB CLEARS AND WRITES TO SHEET1 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 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 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 Else 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 DoEvents 'get source element value vTS = vIn(s) 'check bins Do DoEvents 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) 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 See Also