應用程式 VBA/獲取陣列資料統計
< 應用程式 VBA
這個 VBA 程式碼模組適用於 MS Excel，因為它將一組基本統計資料列印到工作表上。它假設有一個行為良好的數值資料在一維陣列中作為輸入。將生成一個頻率分佈以及該集合的相關統計資料。
- 將整個程式碼清單複製到 Excel 標準模組中，儲存它，然後執行頂層過程。
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