Hi HansK.

Dein Beispiel stimmt nicht mit deine gezeigten Tabelle in mehreren Punkten nicht überein.

Wenn dennoch nur nach Klassen gruppiert werden soll, versuch mal das hier:

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") 'Bereich der Kopfzeile
  
  i = 1 '= row_offset = erste Datenzeile
  
  Do Until WorksheetFunction.CountA(rng.Offset(i)) < rng.Columns.Count
    
    'Range -> Array
    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
    
    'Klasse:
    strJSON = """" & CStr(col(i)(1)(2)) & """:["
    
    For j = 1 To col(i).Count
      If j > 1 Then strJSON = strJSON & ","
      'Name:
      strJSON = strJSON & "{""" & Trim$(rng(1)) & """:""" & CStr(col(i)(j)(1)) & ""","
      'Ort:
      strJSON = strJSON & """" & Trim$(rng(3)) & """:""" & CStr(col(i)(j)(3)) & """}"
    Next
    
    strJSON = strJSON & "]"
    
    'Ausgabe im Direktbereich von VBA
    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

Ausgabe sieht so aus:

{"10a":[{"Name ":"Julian","Ort":"Berlin"},{"Name ":"Stefan","Ort":"Berlin"},{"Name ":"Klaus","Ort":"Berlin"},{"Name ":"Julian","Ort":"Berlin"},{"Name ":"Julian","Ort":"Berlin"}],
"11a":[{"Name ":"Stefan","Ort":"Berlin"},{"Name ":"Klaus","Ort":"Berlin"},{"Name ":"Julian","Ort":"Berlin"}]}

Grüße