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 See Also