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