• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

vba ile https://marketfiyati.org.tr/ sitesinden veri çekme

Katılım
22 Eylül 2012
Mesajlar
1,078
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
Merhaba, hayırlı ramazanlar.

https://marketfiyati.org.tr/ sitesinden vba ile direk veri çekmek mümkün müdür?Daha doğrusu veri çekebilecek vba kodu nasıl olabilir?
 
Katılım
22 Eylül 2012
Mesajlar
1,078
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
İyi akşamlar, bu konuyla ilgili destek almam mümkün mü? Ya da yönlendirici bir cevap.
 

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
1,245
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Site arayüzü büyük ihtimalle JavaScript ile veri çekiyor (HTML’yi “kopyala-yapıştır” gibi almak çoğu zaman yetmiyor
“api.marketfiyati.org.tr” gibi bir alan adı görünüyor ama şu an erişimde 404’a yönleniyor; yani “resmi, dokümante bir public API” bulmak zor.

Site veriyi çoğu zaman JS ile çektiği için “HTML al → tabloya bas” yöntemi sık bozuluyor; ayrıca kullanım koşulları tarafında da dikkatli olmak gerekiyor (bazı paylaşımlarda içerik kaldırma notları var).
 
Katılım
22 Eylül 2012
Mesajlar
1,078
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
Site arayüzü büyük ihtimalle JavaScript ile veri çekiyor (HTML’yi “kopyala-yapıştır” gibi almak çoğu zaman yetmiyor
“api.marketfiyati.org.tr” gibi bir alan adı görünüyor ama şu an erişimde 404’a yönleniyor; yani “resmi, dokümante bir public API” bulmak zor.

Site veriyi çoğu zaman JS ile çektiği için “HTML al → tabloya bas” yöntemi sık bozuluyor; ayrıca kullanım koşulları tarafında da dikkatli olmak gerekiyor (bazı paylaşımlarda içerik kaldırma notları var).

Teşekkürler sayın @muhasebeciyiz , site alt yapısı sanırım Tübitak tarafından oluşturulmuş. Org uzantılı sitelerin veri almak için pratiklik sağlaması gerekir diye düşünerek konu açtım aslında. Ancak tam tersi gibi.
 

netzone

Altın Üye
Katılım
10 Mayıs 2006
Mesajlar
843
Excel Vers. ve Dili
🅾🅵🅵🅸🅲🅴
⎝2024 64 Bit 𝙏𝙍⎠
🆆🅸🅽🅳🅾🆆🆂
⎝11 64 Bit 𝙏𝙍⎠
Altın Üyelik Bitiş Tarihi
12-09-2027
Merhaba @walabi

Sizin de belirttiğiniz gibi Kamunun yararına olacak bir siteden veri çekmek daha kolay olmalıydı ancak günümüz de internet ne kadar hızlı olsa da sitelerin yüklenmesini çok çok hızlı hale getirmek için bazı teknolojiler kullanmak zorundalar, belki talep ederseniz açık bir api key alabilirsiniz bunun için mail atıp şansınızı deneyebilirsiniz.

Yapay Zeka ile belki karşılaşmadığımız bir çözüm varmı diye kontrol ettiğimde; Önerilerinin sonucu hep aynı hata ile karşılaştık [hata kodu:418] bizi bot olarak görüyor.

Bunun üzerine Selenium ile de kesin çözüme ulaşılamayabileceğini belirtti ve ekledi "Ben olsam kod yazmadan Power Automate Desktop (PAD) ile verileri listelerdim" dedi.

marketfiyati.org.tr gibi:
API bot korumalı
  • 418 hatası veriyor
  • Cloudflare var
    olan sitelerde PAD şunları yapabilir:
    • Gerçek Edge / Chrome açar
    • Siteye normal kullanıcı gibi girer
    • Sayfaları gezer
    • Ürün kartlarını okur
    • Fiyatları çeker
    • Excel’e tablo olarak yazar
👉 Cloudflare bunu bot olarak algılamaz çünkü gerçek tarayıcı kullanır.
**Eğer verilere anlık olarak erişmek değil de ara ara fiyat güncellemek ise amacınız, nispeten daha fazla zaman alacak bu çözüm yolunu kullanarak ara ara verileri liste halinde alabilirsiniz.

1️⃣ Excel başlat
2️⃣ Tarayıcıyı başlat
3️⃣ Sayfaya git
4️⃣ Ürün listesini yakala
5️⃣ Ürün içindeki market fiyatlarını döngü ile al
6️⃣ Excel’e yaz
7️⃣ 1 den fazla sayfa varsa → sonraki sayfaya git
8️⃣ Son sayfada dur

İyi çalışmalar.
 
Katılım
22 Eylül 2012
Mesajlar
1,078
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
Merhaba @walabi

Sizin de belirttiğiniz gibi Kamunun yararına olacak bir siteden veri çekmek daha kolay olmalıydı ancak günümüz de internet ne kadar hızlı olsa da sitelerin yüklenmesini çok çok hızlı hale getirmek için bazı teknolojiler kullanmak zorundalar, belki talep ederseniz açık bir api key alabilirsiniz bunun için mail atıp şansınızı deneyebilirsiniz.

Yapay Zeka ile belki karşılaşmadığımız bir çözüm varmı diye kontrol ettiğimde; Önerilerinin sonucu hep aynı hata ile karşılaştık [hata kodu:418] bizi bot olarak görüyor.

Bunun üzerine Selenium ile de kesin çözüme ulaşılamayabileceğini belirtti ve ekledi "Ben olsam kod yazmadan Power Automate Desktop (PAD) ile verileri listelerdim" dedi.



**Eğer verilere anlık olarak erişmek değil de ara ara fiyat güncellemek ise amacınız, nispeten daha fazla zaman alacak bu çözüm yolunu kullanarak ara ara verileri liste halinde alabilirsiniz.

1️⃣ Excel başlat
2️⃣ Tarayıcıyı başlat
3️⃣ Sayfaya git
4️⃣ Ürün listesini yakala
5️⃣ Ürün içindeki market fiyatlarını döngü ile al
6️⃣ Excel’e yaz
7️⃣ 1 den fazla sayfa varsa → sonraki sayfaya git
8️⃣ Son sayfada dur

İyi çalışmalar.

İlginiz için teşekkürler, ben aslında haftalık, aylık, yıllık gibi kıyaslamalar yapabilmek için düşünmüştüm. Ancak mevcut hali ile pratik bir yol yok sanırım, teknik konularına hakim değilim, ama şu da var, 50 binden fazla ürün, ve bu ürünlerin yer aldığı çok sayıda market şubesi. excel açısından da ciddi bir yük sanırım.
 
Katılım
6 Mart 2024
Mesajlar
346
Excel Vers. ve Dili
2010 TR & 2016 TR
Merhaba
1. https://github.com/VBA-tools/VBA-JSON linkini tarayıcınızda açın
2. açılan sayfada "JsonConverter.bas" dosyasını bilgisayarınıza ekleyiniz
3. Boş bir excel dosyası açınız
4. Excel VBE açınız (Alt+F11)
5. "JsonConverter.bas" dosyasını ekleyiniz (import file...)
6. VBE menüde > Tolls > References... >
✅ Microsoft WinHttp Services, Version 5.1
✅ Microsoft Scripting Runtime
seçili konuma getirip
7. excel dosyasını makrolu olarak xlsm kaydedin
8. Makrolardan UrunAra makrosunu çalıştırın

Not:
1. ilk olarak konumu TÜBİTAK merkez ENLEM ve BOYLAM mı nı alır buraya yakın market sonuçlarına bakacak
2. Kendi istediğimiz her hangi bir yerin enlem ve boylamını öğrenmek için
https://maps.google.com/ Adresinden haritada isteğiniz noktayı SAĞ tıklayın ve çıkan iki sayıyı not alın(kopyalayıp)
3. Excel menüsü > Formüller > Ad Yöneticisi tıklayın
MF_LAST_LAT (enlem değeri) ve MF_LAST_LON (boylam değeri)
https://maps.google.com/ dan aldığınız ENLEM ve BOYLAM değerlerini yazınız.

C++:
Option Explicit

' ============================================================
' MarketFiyati - Excel 2016 - Biolight 2026 - Eppur Si Muove
'    1. https://github.com/VBA-tools/VBA-JSON linkini tarayıcınızda açın
'    2. açılan sayfada "JsonConverter.bas" dosyasını bilgisayarınıza ekleyiniz
'    3. Boş bir excel dosyası açınız
'    4. Excel VBE açınız (Alt+F11)
'    5. "JsonConverter.bas" dosyasını ekleyiniz (import file...)
'    6. VBE menüde > Tolls > References... >
'    Microsoft WinHttp Services, Version 5.1
'    Print Microsoft Scripting Runtime
'    seçili konuma getirip
'    7. excel dosyasını makrolu olarak xlsm kaydedin
'    8. Makrolardan UrunAra mkarosunu çalıştırın
'
'    Not:
'    1. ilk olarak konumu TÜBİTAK merkez ENLEM ve BOYLAM mını alır buraya yakın market sonuçlarına bakacak
'    2. Kendi istediğimiz her hangi bir yerin enlem ve boylamını öğrenmek için
'    https://maps.google.com/ Adresinden haritada isteginiz noktayı SAĞ tıklayın ve çıkan iki sayıyı not alın(kopyalayıp)
'    3. Excel menüsü > Formüller > Ad Yöneticisi tıklayın
'    MF_LAST_LAT (enlem değeri) ve MF_LAST_LON (boylam değeri)
'    https://maps.google.com/ dan aldığınız ENLEM ve BOYLAM değerlerini yazınız
' ============================================================
Public Sub UrunAra()
    Dim q As String
    q = InputBox("MarketFiyati araması için ürün adı:", "Ürün Ara", "elma")
    q = Trim$(q)
    If Len(q) = 0 Then Exit Sub

    Dim lat As Double, lon As Double
    GetLatLon lat, lon          ' kayıtlı konumu oku / yoksa TÜBİTAK yaz

    Dim r As Object
    Set r = GetFirstItemInfo(q, lat, lon)
    
    ' Ürün bulunamadıysa (fonksiyon Nothing döndürdüyse) direkt çık
    If r Is Nothing Then Exit Sub

    With ThisWorkbook.Worksheets("Sayfa1")
        .Range("A1").value = "Arama"
        .Range("B1").value = r("query")

        .Range("A2").value = "Market"
        .Range("B2").value = r("market")

        .Range("A3").value = "Birim"
        .Range("B3").value = r("unit")

        .Range("A4").value = "Fiyat"
        .Range("B4").value = r("price")
        .Range("B4").NumberFormat = "0,00"
    End With

    Debug.Print r("query"), r("market"), r("unit"), r("price")
End Sub

' ============================================================
' KONUM: kayitli -> TÜBİTAK
' ============================================================

Private Sub GetLatLon(ByRef lat As Double, ByRef lon As Double)
    ' ENLEM ve BOYLAM Öğrenme
    ' https://maps.google.com/ Adresinden haritada isteginiz noktayı SAĞ tıklayın
    ' çıkan iki sayıyı kopyala.
    
    Const SAVE_LAT As Double = 39.901234   ' TÜBİTAK enlemi
    Const SAVE_LON As Double = 32.781234   ' TÜBİTAK boylamı

    Dim sLat As String, sLon As String
    sLat = GetNameText("MF_LAST_LAT", "")
    sLon = GetNameText("MF_LAST_LON", "")

    If Len(Trim$(sLat)) > 0 And Len(Trim$(sLon)) > 0 Then
        ' Kayıtlı konum var -> sessizce kullan
        lat = ParseDouble(sLat, SAVE_LAT)
        lon = ParseDouble(sLon, SAVE_LON)
    Else
        ' Kayıtlı yok -> TÜBİTAK + mesaj
'        MsgBox "Kayıtlı konum yok! TÜBİTAK konumu kullanıldı.", vbInformation
        lat = SAVE_LAT
        lon = SAVE_LON
        SaveLatLon lat, lon
    End If
End Sub

Private Sub SaveLatLon(ByVal lat As Double, ByVal lon As Double)
    SetNameText "MF_LAST_LAT", ToDot(lat)
    SetNameText "MF_LAST_LON", ToDot(lon)
End Sub

Private Function GetNameText(ByVal nm As String, ByVal defaultValue As String) As String
    Dim s As String
    On Error Resume Next
    s = ThisWorkbook.Names(nm).RefersTo
    On Error GoTo 0

    If Len(s) = 0 Then
        GetNameText = defaultValue
        Exit Function
    End If

    ' ="deger" formatını temizle
    If Left$(s, 2) = "=""" Then
        GetNameText = Mid$(s, 3, Len(s) - 3)
    ElseIf Left$(s, 1) = "=" Then
        GetNameText = Mid$(s, 2)
    Else
        GetNameText = s
    End If
End Function

Private Sub SetNameText(ByVal nm As String, ByVal value As String)
    Dim formula As String
    ' ="deger" şeklinde yazar; var ise üstüne yazar
    formula = "=""" & Replace(value, """", """""") & """"

    On Error Resume Next
    ThisWorkbook.Names(nm).RefersTo = formula
    If Err.Number <> 0 Then
        Err.Clear
        ThisWorkbook.Names.Add Name:=nm, RefersTo:=formula
    End If
    On Error GoTo 0
End Sub

Private Function ParseDouble(ByVal s As String, ByVal defaultVal As Double) As Double
    Dim t As String
    t = Trim$(s)
    If Len(t) = 0 Then
        ParseDouble = defaultVal
        Exit Function
    End If

    ' Hem virgülü hem noktayı, nokta tabanlı formata çevir
    t = Replace(t, ",", ".")
    ' Val, '.' u ondalık ayırıcı gibi yorumlar, bölgesel ayardan bağımsız
    ParseDouble = Val(t)

    ' Eğer Val herhangi bir nedenle 0 döner ve orijinal metin de "0" değilse
    If ParseDouble = 0 And t <> "0" Then
        ParseDouble = defaultVal
    End If
End Function

' ============================================================
' MarketFiyati API (XMLHTTP)
' ============================================================

Public Function GetFirstItemInfo(ByVal keywords As String, _
                                 ByVal lat As Double, _
                                 ByVal lon As Double) As Object
    Dim url As String
    url = "https://api.marketfiyati.org.tr/api/v2/search"

    Dim body As String
    body = "{""keywords"":""" & JsonEscape(keywords) & """,""latitude"":" & ToDot(lat) & _
           ",""longitude"":" & ToDot(lon) & ",""size"":24}"

    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP")

    http.Open "POST", url, False

    http.setRequestHeader "Content-Type", "application/json;charset=UTF-8"
    http.setRequestHeader "Accept", "application/json, text/plain, */*"
    http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/122.0.0.0 Safari/537.36"
    http.setRequestHeader "Origin", "https://marketfiyati.org.tr"
    http.setRequestHeader "Referer", "https://marketfiyati.org.tr/ara?q=" & UrlEncodeSimple(keywords)
    http.setRequestHeader "Accept-Language", "tr-TR,tr;q=0.9,en-US;q=0.8,en;q=0.7"

    http.send body

    If http.Status <> 200 Then
        Err.Raise vbObjectError + 1, , "HTTP " & http.Status & " - " & http.statusText & vbCrLf & Left$(http.responseText, 300)
    End If

    Dim txt As String
    txt = StripBomAndTrim(http.responseText)

    Dim json As Object
    Set json = JsonConverter.ParseJson(txt)

    Dim content As Object
    Set content = json("content")
    If content Is Nothing Or content.Count = 0 Then
        MsgBox "Arama sonucunda ürün bulunamadı.", vbInformation
        Set GetFirstItemInfo = Nothing
        Exit Function
    End If

    Dim firstProd As Object
    Set firstProd = content(1)

    Dim depots As Object
    On Error Resume Next
    Set depots = firstProd("productDepotInfoList")
    On Error GoTo 0

    If depots Is Nothing Or depots.Count = 0 Then
        Err.Raise vbObjectError + 3, , "Market/fiyat listesi bulunamadı (productDepotInfoList)."
    End If

    ' En düşük fiyatlı marketi seç
    Dim bestPrice As Double: bestPrice = 1E+99
    Dim bestMarket As String, bestUnit As String
    Dim i As Long, p As Double

    For i = 1 To depots.Count
        p = CDbl(depots(i)("price"))
        If p < bestPrice Then
            bestPrice = p
            bestMarket = CStr(depots(i)("marketAdi"))
            bestUnit = UnitFromUnitPrice(CStr(depots(i)("unitPrice")))
        End If
    Next i

    Dim result As Object
    Set result = CreateObject("Scripting.Dictionary")
    result("query") = keywords
    result("market") = UCase$(bestMarket)
    result("unit") = UCase$(bestUnit)
    result("price") = bestPrice

    Set GetFirstItemInfo = result
End Function

' ============================================================
' Yardımcı fonksiyonlar
' ============================================================

Private Function JsonEscape(ByVal s As String) As String
    JsonEscape = Replace(s, """", "\""")
End Function

Private Function ToDot(ByVal d As Double) As String
    ToDot = Replace(CStr(d), ",", ".")
End Function

Private Function UrlEncodeSimple(ByVal s As String) As String
    UrlEncodeSimple = Replace(s, " ", "%20")
End Function

Private Function StripBomAndTrim(ByVal s As String) As String
    Dim t As String
    t = s
    t = Replace(t, ChrW(&HFEFF), "")
    t = Replace(t, "", "")
    StripBomAndTrim = Trim$(t)
End Function

Private Function UnitFromUnitPrice(ByVal s As String) As String
    Dim p As Long
    p = InStr(1, s, "/", vbTextCompare)
    If p > 0 Then
        UnitFromUnitPrice = UCase$(Trim$(Mid$(s, p + 1)))
    Else
        UnitFromUnitPrice = ""
    End If
End Function
 
Katılım
22 Eylül 2012
Mesajlar
1,078
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
Merhaba
1. https://github.com/VBA-tools/VBA-JSON linkini tarayıcınızda açın
2. açılan sayfada "JsonConverter.bas" dosyasını bilgisayarınıza ekleyiniz
3. Boş bir excel dosyası açınız
4. Excel VBE açınız (Alt+F11)
5. "JsonConverter.bas" dosyasını ekleyiniz (import file...)
6. VBE menüde > Tolls > References... >
✅ Microsoft WinHttp Services, Version 5.1
✅ Microsoft Scripting Runtime
seçili konuma getirip
7. excel dosyasını makrolu olarak xlsm kaydedin
8. Makrolardan UrunAra makrosunu çalıştırın

Not:
1. ilk olarak konumu TÜBİTAK merkez ENLEM ve BOYLAM mı nı alır buraya yakın market sonuçlarına bakacak
2. Kendi istediğimiz her hangi bir yerin enlem ve boylamını öğrenmek için
https://maps.google.com/ Adresinden haritada isteğiniz noktayı SAĞ tıklayın ve çıkan iki sayıyı not alın(kopyalayıp)
3. Excel menüsü > Formüller > Ad Yöneticisi tıklayın
MF_LAST_LAT (enlem değeri) ve MF_LAST_LON (boylam değeri)
https://maps.google.com/ dan aldığınız ENLEM ve BOYLAM değerlerini yazınız.

C++:
Option Explicit

' ============================================================
' MarketFiyati - Excel 2016 - Biolight 2026 - Eppur Si Muove
'    1. https://github.com/VBA-tools/VBA-JSON linkini tarayıcınızda açın
'    2. açılan sayfada "JsonConverter.bas" dosyasını bilgisayarınıza ekleyiniz
'    3. Boş bir excel dosyası açınız
'    4. Excel VBE açınız (Alt+F11)
'    5. "JsonConverter.bas" dosyasını ekleyiniz (import file...)
'    6. VBE menüde > Tolls > References... >
'    Microsoft WinHttp Services, Version 5.1
'    Print Microsoft Scripting Runtime
'    seçili konuma getirip
'    7. excel dosyasını makrolu olarak xlsm kaydedin
'    8. Makrolardan UrunAra mkarosunu çalıştırın
'
'    Not:
'    1. ilk olarak konumu TÜBİTAK merkez ENLEM ve BOYLAM mını alır buraya yakın market sonuçlarına bakacak
'    2. Kendi istediğimiz her hangi bir yerin enlem ve boylamını öğrenmek için
'    https://maps.google.com/ Adresinden haritada isteginiz noktayı SAĞ tıklayın ve çıkan iki sayıyı not alın(kopyalayıp)
'    3. Excel menüsü > Formüller > Ad Yöneticisi tıklayın
'    MF_LAST_LAT (enlem değeri) ve MF_LAST_LON (boylam değeri)
'    https://maps.google.com/ dan aldığınız ENLEM ve BOYLAM değerlerini yazınız
' ============================================================
Public Sub UrunAra()
    Dim q As String
    q = InputBox("MarketFiyati araması için ürün adı:", "Ürün Ara", "elma")
    q = Trim$(q)
    If Len(q) = 0 Then Exit Sub

    Dim lat As Double, lon As Double
    GetLatLon lat, lon          ' kayıtlı konumu oku / yoksa TÜBİTAK yaz

    Dim r As Object
    Set r = GetFirstItemInfo(q, lat, lon)
   
    ' Ürün bulunamadıysa (fonksiyon Nothing döndürdüyse) direkt çık
    If r Is Nothing Then Exit Sub

    With ThisWorkbook.Worksheets("Sayfa1")
        .Range("A1").value = "Arama"
        .Range("B1").value = r("query")

        .Range("A2").value = "Market"
        .Range("B2").value = r("market")

        .Range("A3").value = "Birim"
        .Range("B3").value = r("unit")

        .Range("A4").value = "Fiyat"
        .Range("B4").value = r("price")
        .Range("B4").NumberFormat = "0,00"
    End With

    Debug.Print r("query"), r("market"), r("unit"), r("price")
End Sub

' ============================================================
' KONUM: kayitli -> TÜBİTAK
' ============================================================

Private Sub GetLatLon(ByRef lat As Double, ByRef lon As Double)
    ' ENLEM ve BOYLAM Öğrenme
    ' https://maps.google.com/ Adresinden haritada isteginiz noktayı SAĞ tıklayın
    ' çıkan iki sayıyı kopyala.
   
    Const SAVE_LAT As Double = 39.901234   ' TÜBİTAK enlemi
    Const SAVE_LON As Double = 32.781234   ' TÜBİTAK boylamı

    Dim sLat As String, sLon As String
    sLat = GetNameText("MF_LAST_LAT", "")
    sLon = GetNameText("MF_LAST_LON", "")

    If Len(Trim$(sLat)) > 0 And Len(Trim$(sLon)) > 0 Then
        ' Kayıtlı konum var -> sessizce kullan
        lat = ParseDouble(sLat, SAVE_LAT)
        lon = ParseDouble(sLon, SAVE_LON)
    Else
        ' Kayıtlı yok -> TÜBİTAK + mesaj
'        MsgBox "Kayıtlı konum yok! TÜBİTAK konumu kullanıldı.", vbInformation
        lat = SAVE_LAT
        lon = SAVE_LON
        SaveLatLon lat, lon
    End If
End Sub

Private Sub SaveLatLon(ByVal lat As Double, ByVal lon As Double)
    SetNameText "MF_LAST_LAT", ToDot(lat)
    SetNameText "MF_LAST_LON", ToDot(lon)
End Sub

Private Function GetNameText(ByVal nm As String, ByVal defaultValue As String) As String
    Dim s As String
    On Error Resume Next
    s = ThisWorkbook.Names(nm).RefersTo
    On Error GoTo 0

    If Len(s) = 0 Then
        GetNameText = defaultValue
        Exit Function
    End If

    ' ="deger" formatını temizle
    If Left$(s, 2) = "=""" Then
        GetNameText = Mid$(s, 3, Len(s) - 3)
    ElseIf Left$(s, 1) = "=" Then
        GetNameText = Mid$(s, 2)
    Else
        GetNameText = s
    End If
End Function

Private Sub SetNameText(ByVal nm As String, ByVal value As String)
    Dim formula As String
    ' ="deger" şeklinde yazar; var ise üstüne yazar
    formula = "=""" & Replace(value, """", """""") & """"

    On Error Resume Next
    ThisWorkbook.Names(nm).RefersTo = formula
    If Err.Number <> 0 Then
        Err.Clear
        ThisWorkbook.Names.Add Name:=nm, RefersTo:=formula
    End If
    On Error GoTo 0
End Sub

Private Function ParseDouble(ByVal s As String, ByVal defaultVal As Double) As Double
    Dim t As String
    t = Trim$(s)
    If Len(t) = 0 Then
        ParseDouble = defaultVal
        Exit Function
    End If

    ' Hem virgülü hem noktayı, nokta tabanlı formata çevir
    t = Replace(t, ",", ".")
    ' Val, '.' u ondalık ayırıcı gibi yorumlar, bölgesel ayardan bağımsız
    ParseDouble = Val(t)

    ' Eğer Val herhangi bir nedenle 0 döner ve orijinal metin de "0" değilse
    If ParseDouble = 0 And t <> "0" Then
        ParseDouble = defaultVal
    End If
End Function

' ============================================================
' MarketFiyati API (XMLHTTP)
' ============================================================

Public Function GetFirstItemInfo(ByVal keywords As String, _
                                 ByVal lat As Double, _
                                 ByVal lon As Double) As Object
    Dim url As String
    url = "https://api.marketfiyati.org.tr/api/v2/search"

    Dim body As String
    body = "{""keywords"":""" & JsonEscape(keywords) & """,""latitude"":" & ToDot(lat) & _
           ",""longitude"":" & ToDot(lon) & ",""size"":24}"

    Dim http As Object
    Set http = CreateObject("MSXML2.XMLHTTP")

    http.Open "POST", url, False

    http.setRequestHeader "Content-Type", "application/json;charset=UTF-8"
    http.setRequestHeader "Accept", "application/json, text/plain, */*"
    http.setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/122.0.0.0 Safari/537.36"
    http.setRequestHeader "Origin", "https://marketfiyati.org.tr"
    http.setRequestHeader "Referer", "https://marketfiyati.org.tr/ara?q=" & UrlEncodeSimple(keywords)
    http.setRequestHeader "Accept-Language", "tr-TR,tr;q=0.9,en-US;q=0.8,en;q=0.7"

    http.send body

    If http.Status <> 200 Then
        Err.Raise vbObjectError + 1, , "HTTP " & http.Status & " - " & http.statusText & vbCrLf & Left$(http.responseText, 300)
    End If

    Dim txt As String
    txt = StripBomAndTrim(http.responseText)

    Dim json As Object
    Set json = JsonConverter.ParseJson(txt)

    Dim content As Object
    Set content = json("content")
    If content Is Nothing Or content.Count = 0 Then
        MsgBox "Arama sonucunda ürün bulunamadı.", vbInformation
        Set GetFirstItemInfo = Nothing
        Exit Function
    End If

    Dim firstProd As Object
    Set firstProd = content(1)

    Dim depots As Object
    On Error Resume Next
    Set depots = firstProd("productDepotInfoList")
    On Error GoTo 0

    If depots Is Nothing Or depots.Count = 0 Then
        Err.Raise vbObjectError + 3, , "Market/fiyat listesi bulunamadı (productDepotInfoList)."
    End If

    ' En düşük fiyatlı marketi seç
    Dim bestPrice As Double: bestPrice = 1E+99
    Dim bestMarket As String, bestUnit As String
    Dim i As Long, p As Double

    For i = 1 To depots.Count
        p = CDbl(depots(i)("price"))
        If p < bestPrice Then
            bestPrice = p
            bestMarket = CStr(depots(i)("marketAdi"))
            bestUnit = UnitFromUnitPrice(CStr(depots(i)("unitPrice")))
        End If
    Next i

    Dim result As Object
    Set result = CreateObject("Scripting.Dictionary")
    result("query") = keywords
    result("market") = UCase$(bestMarket)
    result("unit") = UCase$(bestUnit)
    result("price") = bestPrice

    Set GetFirstItemInfo = result
End Function

' ============================================================
' Yardımcı fonksiyonlar
' ============================================================

Private Function JsonEscape(ByVal s As String) As String
    JsonEscape = Replace(s, """", "\""")
End Function

Private Function ToDot(ByVal d As Double) As String
    ToDot = Replace(CStr(d), ",", ".")
End Function

Private Function UrlEncodeSimple(ByVal s As String) As String
    UrlEncodeSimple = Replace(s, " ", "%20")
End Function

Private Function StripBomAndTrim(ByVal s As String) As String
    Dim t As String
    t = s
    t = Replace(t, ChrW(&HFEFF), "")
    t = Replace(t, "", "")
    StripBomAndTrim = Trim$(t)
End Function

Private Function UnitFromUnitPrice(ByVal s As String) As String
    Dim p As Long
    p = InStr(1, s, "/", vbTextCompare)
    If p > 0 Then
        UnitFromUnitPrice = UCase$(Trim$(Mid$(s, p + 1)))
    Else
        UnitFromUnitPrice = ""
    End If
End Function

Sayın @Biolightant , incelemeden mesaj yazayım dedim. Elinize emeğinize sağlık.
 
Katılım
22 Eylül 2012
Mesajlar
1,078
Excel Vers. ve Dili
excel 2010

excel 2013
Altın Üyelik Bitiş Tarihi
06-08-2025
Sayın @Biolightant , tekrardan teşekkürler, ben uygulamayı kendi bilgisayarımda çalıştırabildim. Kodlar benim için anlaması zor. Ancak dosyanın işleyişinden anladığım şu. Ürün adı girdikçe fiyatı en düşük ürünü raporlamakta. Tek bir ürün arayabiliyoruz ve raporlayabiliyoruz.

Mantığını anlamadığım için şu şekilde sormak istedim. İlgili internet sitesinden yararlanırken lokasyon seçmemiz gerekiyor sanırım. Örneğin koordinatları girdiğimizde belli bir mahalledeki ( koordinata göre ) BİR marketin tüm ürünlerini, yada belli bir mahalledeki ( koordinata göre ) tüm marketlerin tüm ürünlerini excele listeletmek mümkün olur mu acaba?

Benim amacım en düşük fiyatlı ürünü bulmaktan ziyade, belli bir lokasyondaki marketlerin bütün ürünlerini fiyatları ile listelemekti.
 
Üst