• DİKKAT

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

  • Forum yazılımı güncelenmiştir.

    Beklenmedik durumlar görürseniz lütfen yönetime iletin.

Güncel Market Fiyatları İnternetten Bulmak

  • Konbuyu başlatan Konbuyu başlatan 5353
  • Başlangıç tarihi Başlangıç tarihi
C#: 
Sub Test()
'   Haluk - 10/05/2022

    Dim objHTTP As Object, strURL As String
    Dim HTML As Object, Tables As Object, Table As Object
    Dim x As Integer, i As Long, iRow As Long
    
    Range("A1:B" & Rows.Count).ClearContents
    Range("A1:B1") = Array("Ürün", "Fiyat")
    
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "https://www.hapeloglu.com/meyve-sebze?kategori=10,231,308&sayfa=1"
 
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("HTMLFILE")
    HTML.body.innerHTML = objHTTP.responseText
    
    Set Divs = HTML.getElementsByTagName("div")
 
    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "productName detailUrl" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).innerText
        End If
        If Divs(x).classname = "productPrice " Then
            Cells(iRow + 1, 2) = Replace(Divs(x).ChildNodes(0).innerText, " TL KDV Dahil", "") + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
End Sub

.
 
Son düzenleme:
Haluk' Alıntı:
Sub Test() ' Haluk - 10/05/2022 Dim objHTTP As Object, strURL As String Dim HTML As Object, Tables As Object, Table As Object Dim x As Integer, i As Long, iRow As Long Range("A1:B" & Rows.Count).ClearContents Range("A1:B1") = Array("Ürün", "Fiyat") Set objHTTP = CreateObject("MSXML2.XMLHTTP") strURL = "https://www.hapeloglu.com/meyve-sebze?kategori=10,231,308&sayfa=1" objHTTP.Open "GET", strURL, False objHTTP.send Set HTML = CreateObject("HTMLFILE") HTML.body.innerHTML = objHTTP.responseText Set Divs = HTML.getElementsByTagName("div") For x = 0 To Divs.Length - 1 If Divs(x).classname = "productName detailUrl" Then iRow = iRow + 1 Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).innerText End If If Divs(x).classname = "productPrice " Then Cells(iRow + 1, 2) = Replace(Divs(x).ChildNodes(0).innerText, " TL KDV Dahil", "") + 0 Cells(iRow + 1, 2).NumberFormat = "#,##0.00" End If Next End Sub
Genişletmek için tıkla ...
Ustadım çok teşekkürler. Bilgi ne büyük bir güç gerçekten. Paylaşmakta öyle olsa gerek. Saygılar.
 
Merhaba;

Keşke her site için çalışsaydı :)

Her sitenin html kodları farklıdır ve buna göre yukarıdaki kodu siz yeni sitenin html kaynak kodlarına bakarak değiştirmeniz gerekiyor.
 
beab05' Alıntı:
Merhaba;

Keşke her site için çalışsaydı :)

Her sitenin html kodları farklıdır ve buna göre yukarıdaki kodu siz yeni sitenin html kaynak kodlarına bakarak değiştirmeniz gerekiyor.
Genişletmek için tıkla ...
ustat html kaynak kodları hangisi bilemedimki.
 
ustat html kaynak kodları hangisi bilemedimki.
 
Browserda siteyi açın F12 basın çıkacaktır.

Ya da sitede sağ klik yapıp incele derseniz de göreceksiniz.
 
yukarıdaki konu hapeloğlunda çalışıyor imecede HTLM kaynak kodlarından dolayı çalışmıyor bunu nasıl duzeteceğimi bilmiyorum.

Sub Test()
' Haluk - 10/05/2022

Dim objHTTP As Object, strURL As String
Dim HTML As Object, Tables As Object, Table As Object
Dim x As Integer, i As Long, iRow As Long

Range("A1:B" & Rows.Count).ClearContents
Range("A1:B1") = Array("Ürün", "Fiyat")

Set objHTTP = CreateObject("MSXML2.XMLHTTP")
strURL = "https://www.imecemarket.com/meyve-sebze"

objHTTP.Open "GET", strURL, False
objHTTP.send

Set HTML = CreateObject("HTMLFILE")
HTML.body.innerHTML = objHTTP.responseText

Set Divs = HTML.getElementsByTagName("div")

For x = 0 To Divs.Length - 1
If Divs(x).classname = "productName detailUrl" Then
iRow = iRow + 1
Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).innerText
End If
If Divs(x).classname = "productPrice " Then
Cells(iRow + 1, 2) = Replace(Divs(x).ChildNodes(0).innerText, " TL KDV Dahil", "") + 0
Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
End If
Next
End Sub
 
C#: 
Sub Test2()
'   Haluk - 08/03/2023

    Dim objHTTP As Object, strURL As String
    Dim HTML As Object, Tables As Object, Table As Object
    Dim x As Integer, i As Long, iRow As Long
   
    Range("A1:B" & Rows.Count).ClearContents
    Range("A1:B1") = Array("Ürün", "Fiyat")
   
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "https://www.imecemarket.com/meyve-sebze"

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("HTMLFILE")
    HTML.body.innerHTML = objHTTP.responseText
   
    Set Divs = HTML.getElementsByTagName("div")

    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "product-item-container" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).Title
        End If
        If Divs(x).classname = "price" Then
            Cells(iRow + 1, 2) = Split(Divs(x).innerText, " ")(0) + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
End Sub


.
 
Merhaba halük bey yardımlarınız için çok teşekkür ederim.
Her sitenin html kodları farklıdır html kodunu nasıl anlayacağım
If Divs(x).classname = "product-item-container"
 
Merhaba,

Eğer bu tür VBA kodlarına yatkınlığınız yoksa, burada birkaç satırla size konuyu anlatmam çok zor. Kusura bakmayın...

.
 
Tekrar Merhaba Halük Bey Kodu çalıştırdığımda 100 den fazla gıda ürünü olmasına rağmen 21 adet gıda ürünü listeliyor
 
polis-53' Alıntı:
Tekrar Merhaba Halük Bey Kodu çalıştırdığımda 100 den fazla gıda ürünü olmasına rağmen 21 adet gıda ürünü listeliyor
Genişletmek için tıkla ...

Çünkü ilgili sitede her sayfa ayrı bir linktir ve her sayfanın içeriğinin bir döngü içinde alınması ve ilgili kısımların listeye eklenmesi gerekiyor. Tabii bunun için de aslında ilk önce kategoriler alınmalı ve ardından ilgili kategoride kaç tane sayfa olduğu tespit edilmeli.

Örneğin;

htt ps://www.imecemarket.com/meyve-sebze?page=2

htt ps://www.imecemarket.com/meyve-sebze?page=3
.....

gibi..
 
Son düzenleme:
Aşağıda kırmızı ile belirtilen ilaveyi yapın;


Rich (BB code): 
    strURL = "https://www.imecemarket.com/meyve-sebze?limit=100"

.
 
Haluk' Alıntı:
Aşağıda kırmızı ile belirtilen ilaveyi yapın;


Rich (BB code): 
    strURL = "https://www.imecemarket.com/meyve-sebze?limit=100"

.
Genişletmek için tıkla ...

Site yapısında limit parametresi oluyorsa çözüm olabilir tabii ama ilgili sitede maximum 200 ü kabul ediyor ve 200 üzeri ürün varsa yine sayfalama gerekiyor. Gerçi soruyu soran arkadaş için tam olmasa da en uygun çözüm limitli yapması ama 200 yapsın :)
 
beab05' Alıntı:
Site yapısında limit parametresi oluyorsa çözüm olabilir tabii ama ilgili sitede maximum 200 ü kabul ediyor ve 200 üzeri ürün varsa yine sayfalama gerekiyor. Gerçi soruyu soran arkadaş için tam olmasa da en uygun çözüm limitli yapması ama 200 yapsın :)
Genişletmek için tıkla ...


Sayın @beab05 , aşağıdaki kod sizin için uygun olur mu?

C#: 
Sub Test3()
'   Haluk - 09/03/2023

    Dim objHTTP As Object, strURL As String
    Dim HTML As Object, Tables As Object, Table As Object
    Dim x As Integer, i As Long, iRow As Long, j As Integer, iCount As Integer
   
    Range("A1:B" & Rows.Count).ClearContents
    Range("A1:B1") = Array("Ürün", "Fiyat")
   
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "https://www.imecemarket.com/meyve-sebze"

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("HTMLFILE")
    HTML.body.innerHTML = objHTTP.responseText
    
    Set Divs = HTML.getElementsByTagName("div")
    
    For x = 0 To Divs.Length - 1
        If Divs(x).classname = ("product-filter product-filter-bottom filters-panel") Then
            iCount = Split(Split(Divs(x).innerText, "(")(1), " ")(0)
        End If
    Next
    
    For j = 1 To iCount
        strURL = "https://www.imecemarket.com/meyve-sebze?page=" & j
        
        objHTTP.Open "GET", strURL, False
        objHTTP.send
    
        HTML.body.innerHTML = objHTTP.responseText
        
        Set Divs = HTML.getElementsByTagName("div")

        For x = 0 To Divs.Length - 1
            If Divs(x).classname = "product-item-container" Then
                iRow = iRow + 1
                Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).Title
            End If
            If Divs(x).classname = "price" Then
                Cells(iRow + 1, 2) = Split(Divs(x).innerText, " ")(0) + 0
                Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
            End If
        Next
    Next
End Sub

.
 
Son düzenleme:
Rica etsem bu koddada yapabilirmisiniz.



Kod: 
Sub Test()
'   Haluk - 10/05/2022

    Dim objHTTP As Object, strURL As String
    Dim HTML As Object, Tables As Object, Table As Object
    Dim x As Integer, i As Long, iRow As Long
   
    Range("A1:B" & Rows.Count).ClearContents
    Range("A1:B1") = Array("Ürün", "Fiyat")
   
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "https://www.hapeloglu.com/meyve-sebze?kategori=10,231,308&sayfa=1"

    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("HTMLFILE")
    HTML.body.innerHTML = objHTTP.responseText
   
    Set Divs = HTML.getElementsByTagName("div")

    For x = 0 To Divs.Length - 1
        If Divs(x).classname = "productName detailUrl" Then
            iRow = iRow + 1
            Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).innerText
        End If
        If Divs(x).classname = "productPrice " Then
            Cells(iRow + 1, 2) = Replace(Divs(x).ChildNodes(0).innerText, " TL KDV Dahil", "") + 0
            Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
        End If
    Next
End Sub
 
"Hapeloğlu" sitesinde tüm ürünler zaten tek sayfada listeleniyor, onun için gerek yok.

.
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst