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
|