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

See Also

edit