Visual Basic for Applications/数组数据到立即窗口
此 VBA 代码模块允许在立即窗口中列出数组。为了让用户能够看到其用法的示例，它使用了各种用于演示和测试的填充数组的过程。该 VBA 代码在 MS Excel 中运行，但很容易适应任何运行 VBA 的 MS Office 产品。 明显地，混合数据在长度和十进制小数点数量上各不相同。此模块整齐地显示数组，并考虑了可能破坏布局的各种变化。它可以根据内部选项对数据进行小数点对齐或不对齐。
- DispArrInImmWindow() 是主过程。它格式化并打印在二维输入数组中找到的数据。它在 VBA 编辑器的立即窗口中打印。选项包括按原样打印数据或使用十进制舍入和对齐。整个输出打印也可以作为字符串供外部使用。该过程依赖于为任何显示（包括 VBA 编辑器）设置等宽字体。
- RndAlphaToArr()、RndNumericToArr() 和 RndMixedDataToArr() 用随机数据加载数组。数据在内容和元素长度上是随机的，但此外，数字具有随机整数和小数部分。每个都允许内部调整选项以适应个人喜好。
- TabularAlignTxtOrNum() 在此演示中未使用。 它被包含在内，用于那些希望在加载过程中格式化数组的每个单独列的人。它的输入变体接受单个字符串或数字，并在用户设置的固定字段宽度中返回格式化的结果。舍入的小数位数可以设置。请注意，当数字数组的一列中的所有数据都使用相同的参数加载时，结果始终是小数点对齐。
- WriteToFile() 是一个等宽字体，文本文件制作过程。如果文件名不存在，它将自动创建和保存。每次保存文本都会完全替换以前添加的文本。它在这里添加，以防用户需要保存超出立即窗口可能保存的范围的输出。立即窗口限制为大约两百行代码，因此大型数组应该使用主过程的 sOut 字符串。同样，在使用来自主过程的任何输出的地方，都假定使用等宽字体。
- 请注意，用户可能会添加一个过程来将 sOut 的大值（格式化字符串）导出到剪贴板。 此系列中的其他地方存在可以完成此操作的过程。
将整个代码模块复制到标准 VBA 模块中，将文件保存为 .xlsm 类型并运行顶层过程。确保为 VBA 编辑器设置等宽字体，否则对象将失效。
- 2019 年 11 月 26 日：调整 DispArrInImmWindow() 代码以更好地估计最大列宽，并考虑强制实施的小数位数。
Option Explicit
Private Sub testDispArrInImmWindow()
'Run this to display a selection of data arrays
'in the immediate window. Auto formatting
'includes rounding and decimal point alignment.
'Alternative is to print data untouched.
'SET IMMEDIATE WINDOW FONT TO MONOSPACED
'Eg: Consolas or Courier.
Dim vArr As Variant, vArr2 As Variant, sOutput As String
'clear the immediate window
ClearImmWindow
'UNFORMATTED random length alpha strings
RndAlphaToArr vArr, 5, 6 'length setting made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random length alpha strings
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2
'UNFORMATTED random length numbers and decimals
RndNumericToArr vArr, 5, 6 'various settings made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random length numbers and decimals
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2
'UNFORMATTED random alpha and number alternating columns
RndMixedDataToArr vArr, 5, 6 'various settings made in proc
vArr2 = vArr
Debug.Print "UNFORMATTED"
DispArrInImmWindow vArr, False, 2
'FORMATTED random alpha and number alternating columns
Debug.Print "FORMATTED"
DispArrInImmWindow vArr2, True, 2, sOutput
'output whole string version to a log file
'WriteToFile sOutput, ThisWorkbook.Path & "\MyLongArray.txt"
End Sub
Private Sub ClearImmWindow()
'NOTES
'Clears VBA immediate window down to the insertion point,
'but not beyond. Not a problem as long as cursor is
'at end of text, but otherwise not.
'Clear manually before any neat work.
'Manual clear method: Ctrl-G then Ctrl-A then Delete.
'Max display in immediate window is 199 lines,
'then top lines are lost as new ones added at bottom.
'No reliable code method exists.
Debug.Print String(200, vbCrLf)
End Sub
Private Sub DispArrInImmWindow(vA As Variant, Optional ByVal bFormatAlignData = True, _
Optional ByVal nNumDecs As Integer = 2, _
Optional sOut As String)
'--------------------------------------------------------------------------
'vA : Input 2D array for display in the immediate window.
'sOut: Alternative formatted output string.
'bFormatAlignData : True: applies decimal rounding and decimal alignment,
' False: data untouched with only basic column spacing.
'nNumDecs: Sets the rounding up and down of decimal places.
' Integers do not have zeros added at any time.
'Clear the immediate window before each run for best results.
'The immediate window at best lists 199 lines before overwrite, so
'consider using sOut for large arrays. 'ie; use it in a text file
'or userform textbox. Both outputs depend on the use of MONOSPACED fonts,
'so set the font VBA editor or any textbox to Courier or Consolas.
'To set different formats for EVERY column of an array it is best to add
'the formats at loading time with the procedure TabularAlignTxtOrNumber().
'--------------------------------------------------------------------------
'messy when integers are set in array and decimals is set say to 3.
'maybe the measurement of max element width should include a measure
' for any dot or extra imposed decimal places as well
'different for integers and for existing decimals
Dim vD As Variant, vC As Variant, nInterFieldSpace As Integer
Dim sPadding As String, sDecFormat As String, sR As String, sE As String
Dim r As Integer, c As Integer, m As Integer, n As Integer, nP As Integer
Dim nMaxFieldWidth As Integer, bSkip As Boolean
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
'get bounds of input array
LB1 = LBound(vA, 1): UB1 = UBound(vA, 1)
LB2 = LBound(vA, 2): UB2 = UBound(vA, 2)
ReDim vD(LB1 To UB1, LB2 To UB2) 'display
ReDim vC(LB2 To UB2) 'column max
'--------------------------------------
'set distance between fixed width
'fields in the output display
nInterFieldSpace = 3
'not now used
nMaxFieldWidth = 14
'--------------------------------------
If nNumDecs < 0 Then
MsgBox "nNumDecs parameter must not be negative - closing"
Exit Sub
End If
'find widest element in each column
'and adjust it for any imposed decimal places
For c = LB2 To UB2
n = 0: m = 0
For r = LB1 To UB1
'get element length
If IsNumeric(vA(r, c)) Then
If Int(vA(r, c)) = vA(r, c) Then 'is integer
n = Len(vA(r, c)) + 1 + nNumDecs
Else 'is not integer
If Len(vA(r, c)) - Len(Int(vA(r, c))) - 1 >= nNumDecs Then 'no change
n = Len(vA(r, c))
Else 'add the difference in length as result of imposed decimal places
n = Len(vA(r, c)) + (nNumDecs - (Len(vA(r, c)) - Len(Int(vA(r, c))) - 1))
End If
End If
Else
n = Len(vA(r, c))
End If
If n > m Then m = n 'update if longer
Next r
'store the maximum length
'of data in each column
vC(c) = m
Next c
For c = LB2 To UB2
For r = LB1 To UB1
sE = Trim(vA(r, c))
If bFormatAlignData = False Then
sDecFormat = sE
nP = InStr(sE, ".")
bSkip = True
End If
'make a basic format
If bSkip = False Then
nP = InStr(sE, ".")
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
sDecFormat = Format$(sE, "0." & String$(nNumDecs, "0"))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
sDecFormat = Format$(sE, "0") & String$(nNumDecs + 1, Chr(32))
'alpha
ElseIf IsNumeric(sE) = False Then
sDecFormat = sE
End If
End If
'adjust field width to widest in column
bSkip = False
sPadding = Space$(vC(c))
'numeric with a decimal point
If IsNumeric(sE) = True And nP > 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'integer
ElseIf IsNumeric(sE) = True And nP <= 0 Then
vD(r, c) = Right$(sPadding & sDecFormat, vC(c))
'alpha
ElseIf IsNumeric(sE) = False Then
vD(r, c) = Left$(sDecFormat & sPadding, vC(c))
End If
Next r
Next c
'output
sOut = ""
For r = LB1 To UB1
For c = LB2 To UB2
sR = sR & vD(r, c) & Space(nInterFieldSpace) 'concat one row
Next c
Debug.Print sR 'print one row in imm window
sOut = sOut & sR & vbCrLf 'accum one row in output string
sR = ""
Next r
sOut = sOut & vbCrLf
Debug.Print vbCrLf
End Sub
Private Sub RndAlphaToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random string lengths
Dim sT As String, sAccum As String, nMinLenStr As Integer
Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
Dim nAsc As Integer, r As Long, c As Long
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set minimum and maximum strings lengths here
nMinLenStr = 2 'the minimum random text length
nMaxLenStr = 8 'the maximum random text length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
'make one random length string
For n = 1 To nLenWord
nAsc = Int((90 - 65 + 1) * Rnd + 65)
sT = Chr$(nAsc)
sAccum = sAccum & sT
Next n
'store string
vIn(r, c) = sAccum
sAccum = "": sT = ""
Next c
Next r
End Sub
Private Sub RndNumericToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random number lengths
Dim sT1 As String, sT2 As String, nMinLenDec As Integer, sSign As String
Dim sAccum1 As String, sAccum2 As String, nMaxLenDec As Integer
Dim nLenInt As Integer, nLenDecs As Integer, nMinLenInt As Integer
Dim n As Long, r As Long, c As Long, nAsc As Integer, nMaxLenInt As Integer
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set user minimum and maximum settings here
nMinLenDec = 0 'the minumum decimal part length
nMaxLenDec = 4 'the maximum decimal part length
nMinLenInt = 1 'the minimum integer part length
nMaxLenInt = 4 'the maximum integer part length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
'make one random length integer string
For n = 1 To nLenInt
If nLenInt = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
ElseIf nLenInt <> 1 And n = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
Else
nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
End If
sT1 = Chr$(nAsc)
sAccum1 = sAccum1 & sT1
Next n
'make one random length decimal part
For n = 0 To nLenDecs
nAsc = Int((57 - 48 + 1) * Rnd + 48)
sT2 = Chr$(nAsc)
sAccum2 = sAccum2 & sT2
Next n
'decide whether or not a negative number
nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
If nAsc = 5 Then sSign = "-" Else sSign = ""
'store string
If nLenDecs <> 0 Then
vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
Else
vIn(r, c) = CSng(sSign & sAccum1)
End If
sT1 = "": sT2 = ""
sAccum1 = "": sAccum2 = ""
'MsgBox vIn(r, c)
Next c
Next r
End Sub
Private Sub RndMixedDataToArr(vIn As Variant, nRows As Integer, nCols As Integer)
'loads a 2D array in place with random string lengths
Dim sAccum As String, nMinLenStr As Integer, sSign As String
Dim n As Long, nLenWord As Integer, nMaxLenStr As Integer
Dim nAsc As Integer, r As Long, c As Long, nMaxLenDec As Integer
Dim sT As String, sT1 As String, sT2 As String, nMinLenDec As Integer
Dim sAccum1 As String, sAccum2 As String, nMinLenInt As Integer
Dim nLenInt As Integer, nLenDecs As Integer, nMaxLenInt As Integer
Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long
ReDim vIn(1 To nRows, 1 To nCols)
LB1 = LBound(vIn, 1): UB1 = UBound(vIn, 1)
LB2 = LBound(vIn, 2): UB2 = UBound(vIn, 2)
'--------------------------------------------------
'set user minimum and maximum settings here
nMinLenStr = 3 'the minimum random text length
nMaxLenStr = 8 'the maximum random text length
nMinLenDec = 0 'the minumum decimal part length
nMaxLenDec = 4 'the maximum decimal part length
nMinLenInt = 1 'the minimum integer part length
nMaxLenInt = 4 'the maximum integer part length
'--------------------------------------------------
Randomize
For r = LB1 To UB1
For c = LB2 To UB2
If c Mod 2 <> 0 Then
nLenWord = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr)
'make one random length string
For n = 1 To nLenWord
nAsc = Int((90 - 65 + 1) * Rnd + 65)
sT = Chr$(nAsc)
sAccum = sAccum & sT
Next n
'store string
vIn(r, c) = sAccum
sAccum = "": sT = ""
Else
nLenInt = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt)
nLenDecs = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec)
'make one random length integer string
For n = 1 To nLenInt
If nLenInt = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
ElseIf nLenInt <> 1 And n = 1 Then 'exclude zero choice
nAsc = Int((57 - 48 + 1) * Rnd + 48)
Else
nAsc = Int((57 - 49 + 1) * Rnd + 49) 'all other digits
End If
sT1 = Chr$(nAsc)
sAccum1 = sAccum1 & sT1
Next n
'make one random length decimal part
If nLenDecs <> 0 Then
For n = 1 To nLenDecs
nAsc = Int((57 - 48 + 1) * Rnd + 48)
sT2 = Chr$(nAsc)
sAccum2 = sAccum2 & sT2
Next n
Else
sAccum2 = ""
End If
'decide whether or not a negative number
nAsc = Int((5 - 1 + 1) * Rnd + 1) 'one in five negative
If nAsc = 5 Then sSign = "-" Else sSign = ""
'store string
If nLenDecs <> 0 Then
vIn(r, c) = CSng(sSign & sAccum1 & "." & sAccum2)
Else
vIn(r, c) = CSng(sSign & sAccum1)
End If
sT1 = "": sT2 = ""
sAccum1 = "": sAccum2 = ""
End If
Next c
Next r
End Sub
Sub testNumDecAlign()
'produces examples in immediate window for single entries
'clear the immediate window
ClearImmWindow
Debug.Print "|" & TabularAlignTxtOrNum(Cos(30), 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum("Text Heading", 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum(345.746453, 3, 12) & "|"
Debug.Print "|" & TabularAlignTxtOrNum(56.5645, 0, 12) & "|"
Debug.Print vbCrLf
End Sub
Private Function TabularAlignTxtOrNum(vIn As Variant, nNumDecs As Integer, _
nFieldWidth As Integer) As String
'Notes:
'Returns vIn in function name, formatted to given number of decimals,
'and padded for display. VIn can contain an alpha string, a numeric
'string, or a number. nNumDecs is intended number of decimals
'in the output and nFieldWidth is its total padded width.
'Non-numerics are left-aligned and numerics are right-aligned.
'Decimal alignment results when say, all of an array column is
'formatted with the same parameters.
'ASSUMES THAT A MONOSPACED FONT WILL BE USED FOR DISPLAY
Dim sPadding As String, sDecFormat As String
'make a format based on whether numeric and how many decimals
If IsNumeric(vIn) Then
If nNumDecs > 0 Then 'decimals
sDecFormat = Format$(vIn, "0." & String$(nNumDecs, "0"))
Else
sDecFormat = Format$(vIn, "0") 'no decimals
End If
Else
sDecFormat = vIn 'non numeric
End If
'get a space string equal to max width
sPadding = Space$(nFieldWidth)
'combine and limit width
If IsNumeric(vIn) Then
'combine and limit width
TabularAlignTxtOrNum = Right$(sPadding & sDecFormat, nFieldWidth)
Else
TabularAlignTxtOrNum = Left$(sDecFormat & sPadding, nFieldWidth)
End If
End Function
Function WriteToFile(sIn As String, sPath As String) As Boolean
'REPLACES all content of text file with parameter string
'makes file if does not exist
'no layout or formatting - assumes external
Dim Number As Integer
Number = FreeFile 'Get a file number
'write string to file
Open sPath For Output As #Number
Print #Number, sIn
Close #Number
WriteToFile = True
End Function