Visual Basic for Applications/Array Output Transfers
Summary edit
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 edit
- 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 edit
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