VBA - Fast Serialization of Cells to JSON

As a counterpart to the previous post serializing cells to Excel's array literal string here I present serialization to JSON.

We ought to remind ourselves how to parse a JSON array with built in Microsoft ScriptControl thus ...

Sub IllustratingJSONParsing()
    '* Tools->References->Microsoft Script Control 1.0   (msscript.ocx)
    Dim oScriptControl As MSScriptControl.ScriptControl
    Set oScriptControl = New MSScriptControl.ScriptControl
    oScriptControl.Language = "javascript"
    
    Dim oParsed As Object
    Set oParsed = oScriptControl.Eval("([[""a"",""b"",3],[""d"",5.1,""f""]])")
    
    Debug.Assert CallByName(oParsed, "length", VbGet) = 2
    
    Dim oRow0 As Object
    Set oRow0 = CallByName(oParsed, 0, VbGet)
    Debug.Assert CallByName(oRow0, "length", VbGet) = 3
    Debug.Assert CallByName(oRow0, "0", VbGet) = "a"
    Debug.Assert CallByName(oRow0, "1", VbGet) = "b"
    Debug.Assert CallByName(oRow0, "2", VbGet) = 3
    
    Dim oRow1 As Object
    Set oRow1 = CallByName(oParsed, 1, VbGet)
    Debug.Assert CallByName(oRow1, "length", VbGet) = 3
    Debug.Assert CallByName(oRow1, "0", VbGet) = "d"
    Debug.Assert CallByName(oRow1, "1", VbGet) = 5.1
    Debug.Assert CallByName(oRow1, "2", VbGet) = "f"
End Sub

And the code to serialize is very similar to the previous post and is fast because it uses Mid$ as a left hand side operator. Enjoy!

Option Explicit

'VBA - Fast Serialization of Cells to JSON


Function GetRangeJSON(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)
    
    Dim lCursor As Long
    lCursor = 1
    Mid$(sText, 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

        lCursor = lCursor + 1
        Mid$(sText, lCursor, 1) = "["


        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
        
        lCursor = lCursor + 1
        Mid$(sText, lCursor, 1) = "]"
        
    Next

    GetRangeJSON = Left$(sText, lCursor) & "]"
End Function

Function TestGetRangeJson()
    
    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 = GetRangeJSON(rng)
    
    Debug.Assert sRange = "[[""a"",""b"",3],[""d"",5.1,""f""]]"
    
    Dim oScriptControl As MSScriptControl.ScriptControl
    Set oScriptControl = New MSScriptControl.ScriptControl
    oScriptControl.Language = "javascript"
    
    Dim oParsed As Object
    Set oParsed = oScriptControl.Eval(sRange)
    
    
    Debug.Assert CallByName(oParsed, "length", VbGet) = 2
    
    Dim oRow0 As Object
    Set oRow0 = CallByName(oParsed, 0, VbGet)
    Debug.Assert CallByName(oRow0, "length", VbGet) = 3
    Debug.Assert CallByName(oRow0, "0", VbGet) = "a"
    Debug.Assert CallByName(oRow0, "1", VbGet) = "b"
    Debug.Assert CallByName(oRow0, "2", VbGet) = 3
    
    Dim oRow1 As Object
    Set oRow1 = CallByName(oParsed, 1, VbGet)
    Debug.Assert CallByName(oRow1, "length", VbGet) = 3
    Debug.Assert CallByName(oRow1, "0", VbGet) = "d"
    Debug.Assert CallByName(oRow1, "1", VbGet) = 5.1
    Debug.Assert CallByName(oRow1, "2", VbGet) = "f"
    
    
End Function