应用程序 VBA/离散数据箱统计
< 应用程序 VBA
此代码模块旨在用于 MS Excel，因为它将一组统计数据写入工作表。它假定在 1D 数组中存在离散数据，无论是字符串还是数字。打印出一组统计数据，不是针对数组上的原始数据，而是针对在它上面找到的离散值的箱计数。它包括箱计数和其他统计数据的列表。例如，如果数组仅包含具有 1 或 0 值的元素，结果将列出每个元素的总计数，并生成其他统计数据。
- 将整个代码清单复制到 Excel 标准模块中，保存它，然后运行顶部的过程。
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