Excel 中的 VBA/字符频率图表
有时需要从 VBA 生成 Excel 图表。以下代码根据给定的字符串生成一个频率条形图。它在测试模式下显示，输入了一个随机字符串。用户应该用自己的字符串替换该字符串。有各种图表选项。
Option Explicit
Sub Test()
'run this to test the charting of this module
Dim str As String, n As Long
'make random mixed characters (for testing only)
str = MakeLongMixedString(10000)
'make a sorted frequency chart of the characters in str
MakeCharaFreqChart str, 1, "n"
MsgBox "Chart done"
End Sub
Function MakeLongMixedString(nNumChr As Long) As String
'Makes a long capital letters string using rnd VBA function
Dim n As Long, sChr As String, nAsc As Long
Dim nSamp As Long, sAccum As String, c As Long
'========================================================================
' Notes and Conclusions:
' The VBA function rnd is UNSUITED to generation of long random strings.
' Both length and number of repeats increases rapidly near 256 charas.
' Reasonable results can be obtained by keeping below 128 characters.
' For longer strings, consider hash-based methods of generation.
'========================================================================
Do Until c >= nNumChr
DoEvents
Randomize
'A to Z corresponds to asci 65 to 90
nSamp = Int((90 - 48 + 1) * Rnd + 48)
If (nSamp >= 48 And nSamp <= 57) Or (nSamp >= 65 And nSamp <= 90) Then
sChr = Chr(nSamp)
sAccum = sAccum & sChr
c = c + 1
End If
Loop
'MsgBox sAccum
MakeLongMixedString = sAccum
End Function
Sub MakeCharaFreqChart(str As String, bSort As Boolean, sYUnits As String)
'For use in Excel
'makes a character frequency chart using the parameter string str
'bSort=True to sort the chart from highest (left) otherwise unsorted
'sYUnits string sets measurement method, number charas, percentage total, or normalised to max value
Dim vC As Variant, nRow As Long, vRet As Variant
GetCharaCounts str, vC
Select Case LCase(sYUnits)
Case "n", "numbers", "number", "count", "#"
nRow = 1
Case "p", "percent", "percentage", "%"
nRow = 2
Case "r", "relative", "normalized", "normalised"
nRow = 3
End Select
If bSort Then
SortColumns vC, 1, 0, vRet
ChartColumns vRet, 1, 0, nRow, 1, "Selective Distribution of a " & Len(str) & " Character String", _
"Character Set of Interest", "Number of Each"
Else
ChartColumns vC, 1, 0, nRow, 1, "Selective Distribution of a " & Len(str) & " Character String", _
"Character Set of Interest", "Number of Each"
End If
End Sub
Sub GetCharaCounts(sIn As String, vR As Variant)
'loads an array with character counts
Dim vRef As Variant, LBC As Long, UBC As Long, LBR As Long, UBR As Long
Dim vW() As Variant, X() As Variant, Y() As Variant, vRet As Variant
Dim sUC As String, nC As Long, n As Long, sS As String, ValMax As Variant
'Notes for vR and vW loads
'Row 0: the ref chara set from vRef
'Row 1: the number of hits found in str for each chara in ref set
'Row 2: the percentage that hits rep of total charas in str
'Row 3: the normalized values for each chara with max as unity
If sIn = "" Then
MsgBox "Empty input string - closing"
Exit Sub
End If
'load the intended x-axis display set here...add to it or subtract as required
vRef = Array("A", "B", "C", "D", "E", "F", "G", "H", "I", "J", "K", "L", "M", _
"N", "O", "P", "Q", "R", "S", "T", "U", "V", "W", "X", "Y", "Z", _
"0", "1", "2", "3", "4", "5", "6", "7", "8", "9") ' ,"(", ")", ":", ".", ",")
LBC = LBound(vRef): UBC = UBound(vRef)
ReDim vW(0 To 3, LBC To UBC)
LBR = LBound(vW, 1): UBR = UBound(vW, 1)
ReDim X(LBC To UBC)
ReDim Y(LBC To UBC)
sUC = UCase(sIn)
nC = Len(sIn)
For n = LBC To UBC
vW(0, n) = vRef(n) 'all charas to first row
sS = vW(0, n)
'count hits in string for each chara in ref set
vW(1, n) = UBound(Split(sUC, sS)) - LBound(Split(sUC, sS)) 'count hits
'calculate hits as percentages of total chara count
vW(2, n) = Round(((vW(1, n)) * 100 / nC), 1)
Next n
'find max value in array count
SortColumns vW, 1, False, vRet
ValMax = vRet(1, 0)
'normalize to unity as max value
For n = LBC To UBC
vW(3, n) = Round(vW(1, n) / ValMax, 1)
Next n
vR = vW()
End Sub
Sub ChartColumns(ByVal VA As Variant, bColChart As Boolean, RowX As Long, RowY As Long, _
Optional bXValueLabels As Boolean = 0, Optional sTitle As String = "", _
Optional sXAxis As String, Optional sYAxis As String)
'this is the actual chart procedure. It charts the array data in VA
'the array must contain two data rows for the chart; with x and y data
'the chart can be column or scatter chart; RowX and RowY parameters identify the data rows for each axis.
'optional parameters are included for value labels, chart title, x axis label, and y axis label
Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long, n As Long
Dim X As Variant, Y As Variant, sX As String, sY As String, sT As String, oC As Chart
LBR = LBound(VA, 1): UBR = UBound(VA, 1)
LBC = LBound(VA, 2): UBC = UBound(VA, 2)
ReDim X(LBC To UBC)
ReDim Y(LBC To UBC)
'labels for specific charts
If sTitle = "" Then sT = "Title Goes Here" Else sT = sTitle
If sXAxis = "" Then sX = "X Axis Label Goes Here" Else sX = sXAxis
If sYAxis = "" Then sY = "Y Axis Label Goes Here" Else sY = sYAxis
If RowX < LBR Or RowX > UBR Or RowY < LBC Or RowY > UBC Then
MsgBox "Parameter data rows out of range in ChartColumns - closing"
Exit Sub
End If
'transfer data to chart arrays
For n = LBC To UBC
X(n) = VA(RowX, n) 'x axis data
Y(n) = VA(RowY, n) 'y axis data
Next n
'make chart
Charts.Add
'choose a column chart or a scatter chart
If bColChart Then
ActiveChart.ChartType = xlColumnClustered 'column chart
Else
ActiveChart.ChartType = xlXYScatterLinesNoMarkers 'line scatter chart
'ActiveChart.ChartType = xlXYScatter 'point scatter chart
End If
'assign the data and labels to a series
With ActiveChart.SeriesCollection
If .Count = 0 Then .NewSeries
If bXValueLabels And bColChart Then
.Item(1).ApplyDataLabels Type:=xlDataLabelsShowValue
'item(1).DataLabels.Orientation = xlUpward
.Item(1).DataLabels.Orientation = 60
End If
If Val(Application.Version) >= 12 Then
.Item(1).Values = Y
.Item(1).XValues = X
Else
.Item(1).Select
Names.Add "_", X
ExecuteExcel4Macro "series.x(!_)"
Names.Add "_", Y
ExecuteExcel4Macro "series.y(,!_)"
Names("_").Delete
End If
End With
'apply title string, x and y axis strings, and delete legend
With ActiveChart
.HasTitle = True
.ChartTitle.Text = sT
.SetElement (msoElementPrimaryCategoryAxisTitleAdjacentToAxis) 'X
.Axes(xlCategory).AxisTitle.Text = sX
.SetElement (msoElementPrimaryValueAxisTitleRotated) 'Y
.Axes(xlValue).AxisTitle.Text = sY
.Legend.Delete
End With
ActiveChart.ChartArea.Select
End Sub
Sub SortColumns(ByVal VA As Variant, nRow As Long, bAscend As Boolean, vRet As Variant)
'bubblesorts the input array's columns using values in the specified row, ascending or descending, ret in vRet
Dim i As Long, j As Long, bCond As Boolean, Y As Long, t As Variant
Dim LBC As Long, UBC As Long, LBR As Long, UBR As Long
LBR = LBound(VA, 1): UBR = UBound(VA, 1)
LBC = LBound(VA, 2): UBC = UBound(VA, 2)
For i = LBC To UBC - 1
For j = LBC To UBC - 1
If bAscend Then
bCond = VA(nRow, j) > VA(nRow, j + 1)
Else
bCond = VA(nRow, j) < VA(nRow, j + 1)
End If
If bCond Then
For Y = LBR To UBR
t = VA(Y, j)
VA(Y, j) = VA(Y, j + 1)
VA(Y, j + 1) = t
Next Y
End If
Next j
Next i
vRet = VA
End Sub
Sub DeleteAllWorkbookCharts()
'run this manually to delete all charts
'not at this stage called in any procedure
Dim oC
Application.DisplayAlerts = False
For Each oC In ThisWorkbook.Charts
oC.Delete
Next oC
Application.DisplayAlerts = True
End Sub