Visual Basic for Applications/Array Output Transfers

Summary This VBA code module demonstrates four basic methods of array display. It is intended to run in MS Excel, though with the exception of the first method, transfer to the worksheet, it could be adapted easily for MS Word or other MS Office applications that run VBA. Code Notes The code first loads an array with selected random data. Then the entire array is transferred to the worksheet. The data is further formatted and displayed in the immediate window, in well spaced columns. An additional copy of the formatted output is passed to the clipboard for further external use, and it is also sent to a text file to illustrate the method. RndDataToArr() can load an array with random data. The data types can be set as parameters, and further limits can be found within the procedure itself. Alpha, integer, decimal, dates, and mixed data are available, most random in both length and content. Arr1Dor2DtoWorksheet() can transfer either a one-dimensional or two dimensional array to a worksheet. It can be positioned at any location. It checks that an array exists,that it is allocated, and its number of dimensions in setting the transfer range. DispArrInImmWindow() formats and displays a 2D array in the immediate window of the VBA editor. It takes account of all data length in setting the well aligned columns. There are parameters to set maximum decimal places and the choice of decimal point alignment or raw data. The layout can handle mixed columns of text and numbers, though it has best appearance when all data of a column is of the same type. The whole array's formatted output is available as a single string for external use, useful for arrays beyond 199 rows, as too big for the immediate window. CopyToClip() is used to pass a string to the clipboard. It is used here to upload the formatted array string. The clipboard will retain the contents only until the calling application (Excel) closes. It should be noted that other clipboard procedures in this series retain their content until the Windows platform closes. GetFromClip() retrieves the contents of the clipboard. It is used here purely for demonstration. It passes the entire formatted string of the array to a text file. WriteToFile() opens and writes to a named text file. It completely replaces any text that it already contains. If the file does not exist the procedure makes it, in the same directory as the Excel file itself. The VBA Code Module Copy the entire code listing into an Excel VBA module, and run the top procedure to test the four array transfer methods. Save the file as type xlsm. The code writes to Sheet1, and to the immediate window of the VBA editor. Further array listings will be found on the clipboard and in a text file made for the purpose. Option Explicit Private Sub ArrayOutputTests() ' Test procedure for array display '1 array to worksheet '2 formatted array to immediate window '3 formatted array to clipboard '4 formatted array to text file Dim vA As Variant, vB As Variant Dim sArr As String, oSht As Worksheet Dim sIn As String, sOut As String, sSheet As String '------------------------------------------- 'choose worksheet for display '------------------------------------------- sSheet = "Sheet1" Set oSht = ThisWorkbook.Worksheets(sSheet) '------------------------------------------- 'load an array to test '------------------------------------------- RndDataToArr vA, 16, 10, "mixed" vB = vA '------------------------------------------- 'array to the worksheet '------------------------------------------- 'clear the worksheet oSht.Cells.Clear 'transfer array Arr1Dor2DtoWorksheet vA, "Sheet1", 1, 1 'format columns of the sheet With oSht.Cells .Columns.AutoFit .NumberFormat = "General" .NumberFormat = "0.000" 'two decimals End With '------------------------------------------- 'array formatted and to the immediate window '------------------------------------------- 'clear the immediate window ClearImmWindow 'formatted array to immediate window DispArrInImmWindow vB, True, 3, sIn 'get formatted array string for further use sArr = sIn '-------------------------------------------- 'array formatted and to the clipboard '-------------------------------------------- 'formatted array string to clipboard CopyToClip sArr '-------------------------------------------- 'array formatted and to a text file or log '-------------------------------------------- 'retrieve clipboard string sOut = GetFromClip 'formatted array string replaces text file content WriteToFile sOut, ThisWorkbook.Path & "\MyLongArray.txt" '--------------------------------------------- 'release object variables '--------------------------------------------- Set oSht = Nothing End Sub Private Sub RndDataToArr(vIn As Variant, nRows As Integer, nCols As Integer, sType As String) 'Loads a 2D array in place with a choice of random alpha strings 'numbers or dates. Dim LB1 As Long, UB1 As Long, LB2 As Long, UB2 As Long Dim nMinLenStr As Integer, nMaxLenStr As Integer Dim nMinLenDec As Integer, nMaxLenDec As Integer Dim nMinLenInt As Integer, nMaxLenInt As Integer Dim LA As Integer, LI As Integer, sT As String, sT2 As String Dim sAccum As String, sAccum1 As String, sAccum2 As String Dim nDec As Single, LD As Integer, nS As Integer, sDF As String Dim sAlpha As String, sInteger As String, sDecimal As String Dim r As Long, c As Long, bIncMinus As String, bNeg As Boolean Dim dMinDate As Date, dMaxDate As Date, nD As Long '------------------------------------------------------------------------ 'Parameter Notes: 'sType sets the type of data to load into the array. ' "Alpha" loads random length strings of capitals - length set below ' "Integer" loads random length integers - length set below ' "Decimal" loads random integer and decimal parts - length set below ' "Dates" loads random dates throughout - range set below ' "Mixed" loads alternate columns of alpha and decimal data - set below 'nRows is the number of required array rows 'nCols is the number of required array columns 'vIn contains the input array '------------------------------------------------------------------------ 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 = 1 'the minumum decimal part length nMaxLenDec = 3 'the maximum decimal part length nMinLenInt = 1 'the minimum integer part length nMaxLenInt = 5 'the maximum integer part length dMinDate = #1/1/1900# 'earliest date to list dMaxDate = Date 'latest date to list sDF = "dddd, mmm d yyyy" 'random date format bIncMinus = True 'include random minus signs '-------------------------------------------------- 'randomize using system timer Randomize For r = LB1 To UB1 For c = LB2 To UB2 'get random lengths of elements Select Case LCase(sType) Case "alpha" LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr) Case "integer" LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt) Case "decimal" LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt) LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec) Case "mixed" LA = Int((nMaxLenStr - nMinLenStr + 1) * Rnd + nMinLenStr) LI = Int((nMaxLenInt - nMinLenInt + 1) * Rnd + nMinLenInt) LD = Int((nMaxLenDec - nMinLenDec + 1) * Rnd + nMinLenDec) Case "dates" End Select 'make an alpha string Do sT = Chr$(Int((90 - 65 + 1) * Rnd + 65)) sAccum = sAccum & sT Loop Until Len(sAccum) >= LA sAlpha = sAccum sAccum = "": sT = "" 'make an integer Do If LI = 1 Then 'zero permitted sT = Chr$(Int((57 - 48 + 1) * Rnd + 48)) sAccum = sAccum & sT ElseIf LI > 1 And Len(sAccum) = 0 Then 'zero not permitted sT = Chr$(Int((57 - 49 + 1) * Rnd + 49)) sAccum = sAccum & sT Else sT = Chr$(Int((57 - 48 + 1) * Rnd + 48)) sAccum = sAccum & sT End If Loop Until Len(sAccum) >= LI sInteger = sAccum sAccum = "": sT = "" 'make a decimal part Do sT2 = Chr$(Int((57 - 48 + 1) * Rnd + 48)) sAccum2 = sAccum2 & sT2 Loop Until Len(sAccum2) >= LD sDecimal = sAccum2 sAccum = "": sAccum2 = "": sT2 = "" 'decide proportion of negative numbers nS = Int((3 - 0 + 1) * Rnd + 0) If nS = 1 And bIncMinus = True Then sInteger = "-" & sInteger End If 'assign value to array element Select Case LCase(sType) Case "alpha" vIn(r, c) = sAlpha Case "integer" vIn(r, c) = CLng(sInteger) Case "decimal" vIn(r, c) = CSng(sInteger & "." & sDecimal) Case "dates" nD = WorksheetFunction.RandBetween(dMinDate, dMaxDate) vIn(r, c) = Format(nD, sDF) Case "mixed" If c Mod 2 = 0 Then 'alternate columns alpha and decimal vIn(r, c) = CSng(sInteger & "." & sDecimal) Else vIn(r, c) = sAlpha End If End Select Next c Next r End Sub Private Function Arr1Dor2DtoWorksheet(vA As Variant, ByVal sSht As String, _ ByVal nRow As Long, ByVal nCol As Long) As Boolean 'Transfers a one or two dimensioned input array vA to the worksheet, 'with top-left element at cell position nRow,nCol. sSht is the worksheet name. 'Default 2D array transfers are made unchanged and a 1D array is displayed in a row. Dim oSht As Worksheet, rng As Range, rng1 As Range, bProb As Boolean Dim nD As Integer, nR As Integer, nDim As Integer, r As Long, c As Long Dim LBR As Long, UBR As Long, LBC As Long, UBC As Long, vT As Variant 'CHECK THE INPUT ARRAY On Error Resume Next 'is it an array If IsArray(vA) = False Then bProb = True End If 'check if allocated nR = UBound(vA, 1) If Err.Number <> 0 Then bProb = True End If Err.Clear If bProb = False Then 'count dimensions On Error Resume Next Do nD = nD + 1 nR = UBound(vA, nD) Loop Until Err.Number <> 0 Else MsgBox "Parameter is not an array" & _ vbCrLf & "or is unallocated - closing." Exit Function End If 'get number of dimensions Err.Clear nDim = nD - 1: 'MsgBox nDim 'get ref to worksheet Set oSht = ThisWorkbook.Worksheets(sSht) 'set a worksheet range for array Select Case nDim Case 1 'one dimensional array LBR = LBound(vA): UBR = UBound(vA) Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow, nCol + UBR - LBR)) Case 2 'two dimensional array LBR = LBound(vA, 1): UBR = UBound(vA, 1) LBC = LBound(vA, 2): UBC = UBound(vA, 2) Set rng = oSht.Range(oSht.Cells(nRow, nCol), oSht.Cells(nRow + UBR - LBR, nCol + UBC - LBC)) Case Else 'unable to print more dimensions MsgBox "Too many dimensions - closing" Exit Function End Select 'transfer array values to worksheet rng.Value = vA 'release object variables Set oSht = Nothing Set rng = Nothing 'returns Arr1Dor2DtoWorksheet = True End Function 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 Function CopyToClip(sIn As String) As Boolean 'passes the parameter string to the clipboard 'set reference to Microsoft Forms 2.0 Object Library. 'Clipboard cleared when launch application closes. Dim DataOut As DataObject Set DataOut = New DataObject 'first pass textbox text to dataobject DataOut.SetText sIn 'then pass dataobject text to clipboard DataOut.PutInClipboard 'release object variable Set DataOut = Nothing CopyToClip = True End Function Private Function GetFromClip() As String 'passes clipboard text to function name 'If clipboard not text, an error results 'set reference to Microsoft Forms 2.0 Object Library. 'Clipboard cleared when launch application closes. Dim DataIn As DataObject Set DataIn = New DataObject 'clipboard text to dataobject DataIn.GetFromClipboard 'dataobject text to function string GetFromClip = DataIn.GetText 'release object variable Set DataIn = Nothing End Function Private 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