Sub excelToJsonFileExample()
Dim excelRange As Range
Dim jsonItems As New Collection
Dim jsonDictionary As New Dictionary
Dim jsonDictionary1 As New Dictionary
Dim jsonDictionary2 As New Dictionary
Dim jsonFileObject As New FileSystemObject
Dim jsonFileExport As TextStream
Dim i As Long
Dim cell As Variant

Set excelRange = Cells(1, 1).CurrentRegion

'jsonDictionary2.Add "tables", jsonDictionary1
For i = 2 To excelRange.Rows.Count
    'If Not jsonDictionary1.Exists(Key) Then
        'Set jsonDictionary1 = New Dictionary
        'jsonDictionary1.Add "fields", jsonItems
    If Cells(i, 4) <> "id" Then
        jsonDictionary("name") = Cells(i, 4) 'словарь jsonDictionary пополнили ключами и элементами
        jsonDictionary("type") = Cells(i, 5)
        jsonDictionary("displayname") = JsonEncode(ByVal Cells(i, 6))
   
        'jsonItems.Add "fields"
        jsonItems.Add jsonDictionary 'словарь jsonDictionary добавили в коллекцию jsonItems
        Set jsonDictionary = Nothing
    End If
    'End If
Next i

jsonDictionary1.Add "tables", jsonItems 'добавляем в словарь jsonDictionary1 ключ "tables" и все элементы коллекции jsonItems

'change the path below to save where you desire
'Set jsonFileExport = jsonFileObject.CreateTextFile("C:\Users\username\Desktop\jsonExample.json", True)
Set jsonFileExport = jsonFileObject.CreateTextFile(Application.ActiveWorkbook.Path & "\jsonExample.json", True)
'"D:\\\\Json\jsonExample.json"
jsonFileExport.WriteLine ("""version"": ""1.0""")
jsonFileExport.WriteLine (JsonConverter.ConvertToJson(jsonDictionary1, Whitespace:=3))

End Sub