Merhaba arkadaşlar. Örneğin "https://www.hapeloglu.com/meyve-sebze?kategori=10,231,308&sayfa=1 " sayfadaki cins ve fiyat listesini Excel e aktarabilir miyiz ?
DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
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
Ustadım çok teşekkürler. Bilgi ne büyük bir güç gerçekten. Paylaşmakta öyle olsa gerek. Saygılar.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
ustat html kaynak kodları hangisi bilemedimki.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.
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
Çü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.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
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ınAşağıda kırmızı ile belirtilen ilaveyi yapın;
.Rich (BB code):strURL = "https://www.imecemarket.com/meyve-sebze?limit=100"
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![]()
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
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