VBA - Fast Serialization of Cells to Array Literal String

Today on StackOverflow I saw a great answer which utilizes Mid$() as a left hand operator to write into a string buffer. Concatenating strings is always slow and this is why languages such as C# and Java have a StringBuilder class. Using Mid$() on the left hand side of an assignment is VBA's equivalent of StringBuilder.

We can use this Mid$ (StringBuilder) to very quickly serialize a block of cells to an array literal which can be used to save fragments to file or for marshalling across to a web service

As a reminder array literal strings can be passed to Application.Evaluate and so parsed into an array ready to be pasted to cells. They are quite a simple format, the columns are comma separated and the rows semi-colon sepated, strings are quoted and the whole block is wrapped into curly brackets thus ...

Sub IllustratingApplicationEvaluateAndLiterals()
    
    Dim v As Variant
    v = Application.Evaluate("{""a"",""b"",3;""d"",5.1,""f""}")
    
    Debug.Assert v(1, 1) = "a"
    Debug.Assert v(1, 2) = "b"
    Debug.Assert v(1, 3) = 3
    Debug.Assert v(2, 1) = "d"
    Debug.Assert v(2, 2) = 5.1
    Debug.Assert v(2, 3) = "f"
    
End Sub

So now some code to take cells and serialize into an array literal string

Function GetRangeLiteral(ByVal rngSource As Excel.Range)
    Const CELL_LENGTH = 257 'Add 2 for double quotes
    
    With rngSource
        Dim lRows As Long
        lRows = .Rows.Count
        
        Dim lColumns As Long
        lColumns = .Columns.Count
        
        Dim lBufferSize As Long
        lBufferSize = CELL_LENGTH * .Cells.Count + lRows + (lRows * lColumns)
    End With
    
    '* initialise the buffer with spaces then start opening brace
    Dim sText As String
    sText = VBA.Space(lBufferSize)
    Mid$(sText, 1, 1) = "{"
    
    Dim lCursor As Long
    lCursor = 1
    
    Dim vData()
    vData = rngSource.Value

    Dim lRow As Long
    For lRow = 1 To lRows
    
        '* if past first row then we need a row continuation
        If lRow > 1 Then
            lCursor = lCursor + 1
            Mid$(sText, lCursor, 1) = ";"
        End If

        Dim lColumn As Long
        For lColumn = 1 To lColumns
            
            Dim vCell As Variant
            vCell = vData(lRow, lColumn)
            
            Dim lCellLength As Long
            lCellLength = Len(vCell)
            
            '* extend buffer if necessary
            If lCursor + lCellLength + 2 > Len(sText) Then sText = sText & Space(CDbl(lBufferSize / 4))
            
            '* if past first column then we need a cell continuation
            If lColumn > 1 Then
                lCursor = lCursor + 1
                Mid(sText, lCursor, 1) = ","
            End If

    
            '* write in value directly into buffer, wrap quotes around strings
            If (VBA.TypeName(vCell) = "String") Then
                lCellLength = lCellLength + 2
                Mid$(sText, lCursor + 1, lCellLength) = """" & vCell & """"
            Else
                Mid$(sText, lCursor + 1, lCellLength) = vCell
            End If
            
            '* increment cursor
            lCursor = lCursor + lCellLength
        Next
    Next

    GetRangeLiteral = Left$(sText, lCursor) & "}"
End Function

Function TestGetRangeLiteral()
    
    Dim rng As Excel.Range
    Set rng = ThisWorkbook.Worksheets.Item(4).Range("c3:e4")
    rng.Cells(1, 1) = "a"
    rng.Cells(1, 2) = "b"
    rng.Cells(1, 3) = 3
    rng.Cells(2, 1) = "d"
    rng.Cells(2, 2) = 5.1
    rng.Cells(2, 3) = "f"
    
    Dim sRange As String
    sRange = GetRangeLiteral(rng)
    
    Debug.Assert sRange = "{""a"",""b"",3;""d"",5.1,""f""}"
    
    Dim v As Variant
    v = Application.Evaluate(sRange)
    Debug.Assert v(1, 1) = "a"
    Debug.Assert v(1, 2) = "b"
    Debug.Assert v(1, 3) = 3
    Debug.Assert v(2, 1) = "d"
    Debug.Assert v(2, 2) = 5.1
    Debug.Assert v(2, 3) = "f"
    
End Function

Make VBA Array Literals plus some variables

So just browsing a Python tutorial currently and it is impressive how newer languages such as Python and Javascript have the ability to create tuples and data structures on the fly. VBA has an array literal syntax which can accept both numbers and strings but supplying a variable into one of the locations breaks. So I've decided to write some code and might as well share

Sub DemoMakeArrayLiteral()
    Dim v
    v = [{1,2;3,4}]
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = 2
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = 4
    
    Dim v2
    v2 = [{1,2;3,"foo"}] '* with a string literal
    Debug.Assert v2(1, 1) = 1
    Debug.Assert v2(1, 2) = 2
    Debug.Assert v2(2, 1) = 3
    Debug.Assert v2(2, 2) = "foo"
    
    Dim a
    a = "bar"
    Dim v3
    v3 = [{1,2;3,a}] '* WRONG WAY for a variable, contaminates whole array
    Debug.Assert IsError(v3)

    Dim v4
    v4 = MakeArrayLiteral([{1,2;3,"$0"}], a) '* RIGHT WAY for a variable
    Debug.Assert v4(1, 1) = 1
    Debug.Assert v4(1, 2) = 2
    Debug.Assert v4(2, 1) = 3
    Debug.Assert v4(2, 2) = "bar"


End Sub





Private Function MakeArrayLiteral(ByVal vSeed As Variant, ParamArray args() As Variant) As Variant
    
    If IsError(vSeed) Then GoTo SingleExit
    
    Dim lArgCount As Long
    lArgCount = UBound(args) - LBound(args) + 1
    
    If lArgCount > 0 Then
        
        Dim dicReplacements As Scripting.Dictionary
        
        Dim dicGetDimsAndBounds As Scripting.Dictionary
        Set dicGetDimsAndBounds = GetDimsAndBounds(vSeed)
        
        Dim lDollarNum As Long
        lDollarNum = -1
        
        If dicGetDimsAndBounds.Count = 0 Then
            lDollarNum = GetDollarNum(vSeed)
            If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                vSeed = Replace(vSeed, "$" & lDollarNum, args(lDollarNum))
            End If
        ElseIf dicGetDimsAndBounds.Count = 1 Then
        
            'Stop
            Dim vBounds As Variant
            vBounds = dicGetDimsAndBounds.Item(1)
            Dim lIndex As Long
            For lIndex = vBounds(0) To vBounds(1)
                lDollarNum = GetDollarNum(vSeed(lIndex))
                If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                    vSeed(lIndex) = Replace(vSeed(lIndex), "$" & lDollarNum, args(lDollarNum))
                End If
            Next
        
        ElseIf dicGetDimsAndBounds.Count = 2 Then
            Dim vYBounds As Variant
            vYBounds = dicGetDimsAndBounds.Item(1)
        
            Dim vXBounds As Variant
            vXBounds = dicGetDimsAndBounds.Item(2)
        
            Dim lXIndex As Long
            For lXIndex = vXBounds(0) To vXBounds(1)
                
                Dim lYIndex As Long
                For lYIndex = vYBounds(0) To vYBounds(1)
                
                    lDollarNum = GetDollarNum(vSeed(lYIndex, lXIndex))
                    If lDollarNum <> -1 And lDollarNum <= lArgCount - 1 Then
                        vSeed(lYIndex, lXIndex) = Replace(vSeed(lYIndex, lXIndex), "$" & lDollarNum, args(lDollarNum))
                    End If
        
                Next
            Next
        
        ElseIf dicGetDimsAndBounds.Count > 2 Then
            Err.Raise vbObjectError, , "#Dimensions greater than 2 not yet supported!"
        End If
        
    
    
    
    
    End If
SingleExit:
    MakeArrayLiteral = vSeed
End Function


Private Function GetDims(ByRef v) As Long
    On Error GoTo BadDimension
    GetDims = 0
    Dim lDim As Long
    For lDim = 1 To 100
        Dim vTest As Variant
        vTest = LBound(v, lDim)
        GetDims = lDim
    Next lDim
SingleExit:
    Exit Function
BadDimension:
    GoTo SingleExit
End Function


Private Function GetDimsAndBounds(v As Variant) As Scripting.Dictionary

    Dim dic As Scripting.Dictionary
    Set dic = New Scripting.Dictionary
    
    Dim lDims As Long
    lDims = GetDims(v)
    
    Dim lDimLoop As Long
    For lDimLoop = 1 To lDims
        
        ReDim bounds(0 To 1)
        bounds(0) = LBound(v, lDimLoop)
        bounds(1) = UBound(v, lDimLoop)
        dic.Add lDimLoop, bounds
    
    Next
    Set GetDimsAndBounds = dic

End Function

Private Function GetDollarNum(ByRef v) As Long

    Debug.Assert Not IsError(v)


    GetDollarNum = -1
    
    

    Static reDollarNum As VBScript_RegExp_55.RegExp
    If reDollarNum Is Nothing Then
        Set reDollarNum = New VBScript_RegExp_55.RegExp
        reDollarNum.Pattern = "\$(\d+)"
    End If

    If reDollarNum.Test(v) Then
        Dim oMatchCol As VBScript_RegExp_55.MatchCollection
        Set oMatchCol = reDollarNum.Execute(v)
        If oMatchCol.Count = 1 Then
            Dim oMatch As VBScript_RegExp_55.Match
            Set oMatch = oMatchCol.Item(0)
            If oMatch.SubMatches.Count = 1 Then
                GetDollarNum = CLng(oMatch.SubMatches(0))
            End If
        End If
    End If

End Function

'* UNIT TESTS
Private Sub TestGetDollarNum()

    Debug.Assert GetDollarNum("$456") = 456
    Debug.Assert GetDollarNum("$45.6") = 45
    Debug.Assert GetDollarNum("$6") = 6
    Debug.Assert GetDollarNum("$77") = 77
    Debug.Assert GetDollarNum("$") = -1

End Sub

Private Sub TestGetDims()
    Dim scalar As Variant
    scalar = 1
    Debug.Assert GetDims(scalar) = 0

    Dim v1
    v1 = [{1,2}]
    Debug.Assert GetDims(v1) = 1

    Dim v
    v = [{1,2;3,4}]
    Debug.Assert GetDims(v) = 2

    Dim z
    z = [{"1","2";"3","4"}]
    Debug.Assert GetDims(z) = 2
End Sub

Sub TestMakeArrayLiteral()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2;3,4}])
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = 2
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = 4
    
End Sub


Sub TestMakeArrayLiteral0()
    Dim v As Variant
    v = MakeArrayLiteral("$0", "FOO")
    Debug.Assert v = "FOO"
    
End Sub

Sub TestMakeArrayLiteral1()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2,"$0"}], "FOO")
    Debug.Assert v(3) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral2()
    Dim v As Variant
    v = MakeArrayLiteral([{1,2;3,"$0"}], "FOO")
    Debug.Assert v(2, 2) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral3()
    Dim v As Variant
    v = MakeArrayLiteral([{1,"$1";3,"$0"}], "FOO", "BAR")
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = "BAR"
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = "FOO"
    
End Sub

Sub TestMakeArrayLiteral4()
    Dim v As Variant
    v = MakeArrayLiteral([{1,"$1fly";3,"$0"}], "FOO", "BAR")
    Debug.Assert v(1, 1) = 1
    Debug.Assert v(1, 2) = "BARfly"
    Debug.Assert v(2, 1) = 3
    Debug.Assert v(2, 2) = "FOO"
    
End Sub