Visual Basic for Applications/Array Data To Immediate Window

Summary This VBA code module allows the listing of arrays in the immediate window. So that the user can see examples of its use, it makes use of various procedures that fill the array for demonstration and testing. The VBA code runs in MS Excel but is easily adapted for any of the MS Office products that run VBA. Clearly, mixed data varies in length and in its number of decimal points. This module displays the array neatly taking account of the variations that might otherwise disrupt the layout. It can decimal point align the data or not, according to internal options. Code Notes DispArrInImmWindow() is the main procedure. It formats and prints data found on the two dimensional input array. It prints on the VBA Editor's Immediate Window. Options include the printing of data as found or making use of decimal rounding and alignment. The entire output print is also available as a string for external use. The process depends on monospaced fonts being set for any display, including the VBA editor. RndAlphaToArr(), RndNumericToArr(), and RndMixedDataToArr() load an array with random data. The data is random in the content and length of elements, but in addition, numerics have random integer and decimal parts. Each allows adjustment of options internally to accommodate personal preferences. TabularAlignTxtOrNum() is not used in this demonstration. It is included for those who prefer to format each individual column of an array during the loading process. Its input variant takes a single string or number and returns the formatted result in a user-set fixed field width. The number of decimal places of rounding can be set. Note that when all data in a column of a numeric array is loaded with the same parameters, the result is always decimal point alignment. WriteToFile() is a monospaced font, text file-making procedure. If the file name does not exist, it will be made and saved automatically. Each save of text will completely replace any previously added. It is added here in case a user needs to save an output greater than that possible for the Immediate Window. The Immediate Window is limited to about two hundred lines of code, so large arrays should make use of the main procedure's sOut string. Again, wherever outputs from the main procedure are used, monospaced fonts are assumed. Note that the user might add a procedure to export large values of sOut, the formatted string, to the clipboard. Procedures exist elsewhere in this series that will accomplish this. The VBA Module Copy the entire code module into a standard VBA module, save the file as type .xlsm and run the top procedure. Be sure to set monospaced fonts for the VBA editor or the object will have been defeated. Updates 26 Nov 2019: Adjusted DispArrInImmWindow() code to better estimate maximum column width, taking account of imposed decimal places. 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 See Also