Option Explicit
Sub Test()
Dim col As VBA.Collection
Dim rng As Excel.Range
Dim strJSON As String
Dim i As Long
Dim j As Long
Set col = New VBA.Collection
Set rng = Range("A1:C1")
i = 1
Do Until WorksheetFunction.CountA(rng.Offset(i)) < rng.Columns.Count
vntItem = WorksheetFunction.Transpose(rng.Offset(i))
vntItem = WorksheetFunction.Transpose(vntItem)
On Error Resume Next
Call col.Add(New VBA.Collection, CStr(vntItem(2)))
On Error GoTo 0
Call col(CStr(vntItem(2))).Add(vntItem)
i = i + 1
Loop
For i = 1 To col.Count
strJSON = """" & CStr(col(i)(1)(2)) & """:["
For j = 1 To col(i).Count
If j > 1 Then strJSON = strJSON & ","
strJSON = strJSON & "{""" & Trim$(rng(1)) & """:""" & CStr(col(i)(j)(1)) & ""","
strJSON = strJSON & """" & Trim$(rng(3)) & """:""" & CStr(col(i)(j)(3)) & """}"
Next
strJSON = strJSON & "]"
If i = 1 Then
If col.Count > 1 Then
Debug.Print "{" & strJSON & ","
Else
Debug.Print "{" & strJSON
End If
ElseIf i < col.Count Then
Debug.Print strJSON & ","
Else
Debug.Print strJSON & "}"
End If
Next
End Sub