• Merhaba Ziyaretçi,
    Microsoft 365 Uygulamaları ile ilgili yeni haberler, dikkat çekici konular, ilgi ile takip edeceğiniz yazılar için.

    Abone Olun
  • ESTE - Microsoft Office Eğitimleri

    Yeni yıl Microsoft Office Eğitim planlarınız için bütçenizi oluşturmadan önce ESTE eğitim kalitesi ile tanışın. 🙌
    Kullanıcıların ihtiyacı olan yazılı materyal, dosya ve video kaynağı desteğimiz ile tüm ofis çalışanlarının iş süreçlerini rahatlatacak eğitimler planlayın. 🎯
    Microsoft Office eğitimlerimiz hakkında detaylı bilgi için bize ulaşın.

    👉 Microsoft Office Eğitim Talebi

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

Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...

johnvaldetine

Yeni Üye
Katılım
6 Eyl 2018
Mesajlar
2
En iyi yanıt
0
Puanları
1
Yaş
35
Konum
Ankara
Ad Soyad
Emre
Aşağıdaki excel tablosunu json'a döken 2 vba yazdım ama bir türlü json syntax'ına uyduramıyorum.

Tablo:


şehir

isim

soyisim

yaş

adana

ahmet

irtegün

32

adana

mert

fırat

42

istanbul

kuzey

güney

23

ankara

doktor

mehmet

45


Amacım; sehir sütununda 1 ve 2. satırlarındaki adana verisini adana: [{ }] şeklinde dizi (array) içine alması. Yani, tekrarlanan şehir sütununda hangi veriler varsa o şehirlerin diğer sütunlardaki verilerini dizi içine alsın. Tablodaki "istanbul" gibi tek bir veri varsa Json string içine alsın.

Örnek tablonun istediğim Json çıktısı şu şekilde:


JSON:
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"
}
}

Benim yazdığım vba kodlarından biri ise şu:

PHP:
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

Bu kodu çalıştırdığımda istediğim sonucu alamıyorum.

Yardımlarınızı rica ederim.
 
Son düzenleme:

Murat OSMA

Yönetici
Site Yöneticisi
Katılım
25 May 2018
Mesajlar
1,608
En iyi yanıt
14
Puanları
113
Konum
İstanbul
Web sitesi
excelarsivi.com
Ad Soyad
Murat OSMA
Office Vers.
Office 365 TR+EN
Merhaba,
Bu kodları bir deneyin..
PHP:
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
 
Durum
Üzgünüz bu konu cevaplar için kapatılmıştır...
Üst Alt