Çözüldü VBA ile Json Syntax Yazımı

var isim = {
"adana": [{
"sehir":"adana",
"isim":"ahmet",
"soyisim":"irtegün",
"yaş":"32"
},
{
"sehir":"adana",
"isim":"mert",
"soyisim":"fırat",
"yaş":"42"
}],
"istanbul": {
"sehir":"istanbul",
"isim":"kuzey",
"soyisim":"güney",
"yaş":"23"
},
"ankara": {
"sehir":"ankara",
"isim":"doktor",
"soyisim":"mehmet",
"yaş":"45"
}
}

Public Sub denemeJson()
    savename = "deneme.json"
    Dim wkb As Workbook
    Dim wks As Worksheet
    Set wkb = ThisWorkbook
    Set wks = wkb.Sheets(3)
    lcolumn = wks.Cells(1, Columns.Count).End(xlToLeft).Column
    lrow = wks.Cells(Rows.Count, "A").End(xlUp).Row
    Dim titles() As String
    ReDim titles(lcolumn)
    For i = 1 To lcolumn
        titles(i) = wks.Cells(1, i)
    Next i
    
    ' JS Nesnesini oluşturduk.
    
    json = "var bilgiler = { " & vbCrLf
    dq = """"
    
    k = 1
    
  ' ================= BAŞLANGIÇ =================
    
 
    For j = 2 To lrow
    
 
    sehir = wks.Cells(j, 1).Text
    
    kacKere = Application.WorksheetFunction.CountIf(Range("A1000:A1"), sehir)
    
    
            ' 1 tane olanlar.
            
            If kacKere = 1 Then
                  
                      json = json & dq & sehir & dq & ": {" & vbCrLf
                      
                      For i = 1 To lcolumn
                                  
                      cellvalue = wks.Cells(j, i)
                          
                      json = json & dq & titles(i) & dq & ":" & dq & cellvalue & dq
                      
                        If i <> lcolumn Then            ' Son sütun değilse
                        json = json & "," & vbCrLf
                        End If
                              
                      Next i
                      
                      json = json & vbCrLf & "},"
                      
                End If

                ' 2 tane olanlar..
                
                    If kacKere = 2 Then
                
                            json = json & dq & sehir & dq & ": [{" & vbCrLf
                
                            For i = 1 To lcolumn
                        
                            cellvalue = wks.Cells(j, i)
                            
                            json = json & dq & titles(i) & dq & ":" & dq & cellvalue & dq & "," & vbCrLf
                            
                            Next i
                            
                            json = json & vbCrLf & "},"
                            
                            json = json & "{" & vbCrLf
                            
                            For i = 1 To lcolumn
                        
                            cellvalue = wks.Cells(j + 1, i)
                            
                            json = json & dq & titles(i) & dq & ":" & dq & cellvalue & dq & "," & vbCrLf
                            
                            Next i
                            
                            json = json & vbCrLf & "}],"
                            
                            j = j + 1
                      
                         End If
        
    
            
        
  
    ' 2'den büyük olanlar
  
    If kacKere > 2 Then
        
        For k = 1 To kacKere
        
            If k = 1 Then
            
                json = json & dq & sehir & dq & ": [{" & vbCrLf
                
                For i = 1 To lcolumn
            
                cellvalue = wks.Cells(j, i)
                
                json = json & dq & titles(i) & dq & ":" & dq & cellvalue & dq & ","
                
                Next i
                
                json = json & vbCrLf & "}," & vbCrLf
                
                End If
                
                Next k
                
                 j = j + 1
            
            If k = 2 Then
            
                json = json & dq & "{" & vbCrLf
                
                For i = 1 To lcolumn
            
                cellvalue = wks.Cells(j, i)
                
                json = json & dq & titles(i + 1) & dq & ":" & dq & cellvalue & dq & ","
                
                Next i
                
                json = json & vbCrLf & "},"
                
                End If
                
                 k = k + 1
                
                 j = j + 1
 
         If k = kacKere Then
            
                json = json & dq & "{" & vbCrLf
                
                For i = 1 To lcolumn
            
                cellvalue = wks.Cells(j, i)
                
                json = json & dq & titles(i + 1) & dq & ":" & dq & cellvalue & dq & ","
                
                Next i
                
                json = json & vbCrLf & "}],"
                  
        End If
        
      
        
        End If
        
        Next j
            
        
    
 
    json = json & vbCrLf & "}"
    myFile = "C:\Users\xx\Desktop\" & savename
    Open myFile For Output As #1
    Print #1, json
    Close #1
    'a = MsgBox("Saved as " & savename, vbOKOnly)
End Sub

Sub ExcelTurkey()
    Dim tablo As Range, veri, baslik As Long, ilk As Range, sut As Long, json As String
    Set tablo = Range("A1:D5")
    Set ilk = Range(tablo.Rows(1).Address)
    sut = ilk.Columns.Count
    json = "["
    For veri = 1 To tablo.Rows.Count
        If veri > 1 Then
            Dim sat As String: sat = "{"
            For baslik = 1 To sut
                sat = sat & """" & ilk.Value2(1, baslik) & """" & ":"
                sat = sat & """" & tablo.Value2(veri, baslik) & """"
                sat = sat & ","
            Next baslik
            sat = Left(sat, Len(sat) - 1)
            json = json & sat & "}," & Chr(10)
        End If
    Next
    json = Left(json, Len(json) - 1)
    json = json & "]"
    dosyam = Environ("USERPROFILE") & "\Desktop\test.json"
    Open dosyam For Output As #1
    Print #1, json
    Close #1
    MsgBox "İşlem Tamamlandı.", vbInformation, "Www.ExcelTurkey.Com"
End Sub