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
Dim scriptTags As Object, scriptTag As Object
Range("A1:C" & Rows.Count).ClearContents
Range("A1:C1") = Array("Ürün", "Fiyat", "Barkod")
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
strURL = "https://www.hapeloglu.com/meyve-sebze"
'strURL = "https://www.hapeloglu.com/temizlik-seti-1022"
objHTTP.Open "GET", strURL, False
objHTTP.Send
Set html = CreateObject("HTMLFILE")
html.body.innerHTML = objHTTP.ResponseText
html.Open
html.Write objHTTP.ResponseText
'html.Close
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
'-------------------------------------------------------------------------------------------------------
Set scriptTags = html.getElementsByTagName("script")
For Each scriptTag In scriptTags
On Error Resume Next
If scriptTag.getAttribute("type") = "application/ld+json" Then
jsonText = scriptTag.innerHTML
Exit For
End If
Next
Set re = CreateObject("VBScript.RegExp")
re.Global = True
re.IgnoreCase = True
re.Pattern = """sku""\s*:\s*""([^""]+)"""
Set matches = re.Execute(jsonText)
i = 2
For Each m In matches
Cells(i, 3).Value = m.SubMatches(0)
Cells(i, 3).NumberFormat = "0"
i = i + 1
Next
Cells.EntireColumn.AutoFit
End Sub
Sub Test()
Dim objHTTP As Object, strURL As String
Dim x As Integer, i As Long, iRow As Long
Dim html As New HTMLDocument
Dim html2 As New HTMLDocument
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Range("A1:C" & Rows.Count).ClearContents
Range("A1:C1") = Array("Ürün", "Fiyat", "Barkod")
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
strURL = "https://www.hapeloglu.com/meyve-sebze"
'strURL = "https://www.hapeloglu.com/temizlik-seti-1022"
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 = "productName detailUrl" Then
iRow = iRow + 1
Cells(iRow + 1, 1) = Divs(x).getElementsByTagName("a")(0).innerText
link = Divs(x).ChildNodes.Item(0).pathname
url = "https://www.hapeloglu.com/" & link
objHTTP.Open "GET", url, False
objHTTP.Send
'Set html2 = CreateObject("HTMLFILE")
html2.body.innerHTML = objHTTP.responseText
Set elem = html2.getElementById("divUrunKodu")
stokKodu = elem.getAttribute("content")
Cells(iRow + 1, 3) = Split(stokKodu, ":")(1)
Cells(iRow + 1, 3).NumberFormat = "0"
fiyat = Replace(html2.querySelector(".spanFiyat").innerText, " TL", "")
Cells(iRow + 1, 2) = fiyat * 1
Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
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
'-------------------------------------------------------------------------------------------------------
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "İşlem tamamlandı." & Chr(10) _
& Format(Timer - Zaman, "0.00")
End SubSub Test()
Dim objHTTP As Object, strURL As String
Dim x As Integer, iRow As Long
Dim html As New HTMLDocument
Dim html2 As New HTMLDocument
Zaman = Timer
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Range("A1:C" & Rows.Count).ClearContents
Range("A1:C1") = Array("Ürün", "Fiyat", "Barkod")
syf = 1
Set objHTTP = CreateObject("MSXML2.XMLHTTP")
'strURL = "https://www.hapeloglu.com/meyve-sebze"
'strURL = "https://www.hapeloglu.com/temizlik-seti-1022"
Do
strURL = "https://www.hapeloglu.com/temel-gida?sayfa=" & syf
'strURL = "https://www.hapeloglu.com/bakliyat-432?sayfa=" & syf
objHTTP.Open "GET", strURL, False
objHTTP.Send
If objHTTP.Status = 200 Then
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
'--------------------------------------------------------------------------------------------
link = Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace(Replace( _
Divs(x).ChildNodes.Item(0).pathname, "ç", "%C3%A7"), "Ç", "%C3%87"), "ğ", "%C4%9F"), "Ğ", "%C4%9E"), "ı", "%C4%B1"), "İ", "%C4%B0"), _
"ö", "%C3%B6"), "Ö", "%C3%96"), "ş", "%C5%9F"), "Ş", "%C5%9E"), "ü", "%C3%BC"), "Ü", "%C3%9C")
'--------------------------------------------------------------------------------------------
url = "https://www.hapeloglu.com/" & link
objHTTP.Open "GET", url, False
objHTTP.Send
If objHTTP.Status = 200 Then
'Set html2 = CreateObject("HTMLFILE")
html2.body.innerHTML = objHTTP.responseText
Set elem = html2.getElementById("divUrunKodu")
stokKodu = elem.getAttribute("content")
Cells(iRow + 1, 3) = Split(stokKodu, ":")(1)
Cells(iRow + 1, 3).NumberFormat = "0"
If syf = 1 And iRow = 1 Then
bas = Split(stokKodu, ":")(1)
End If
If syf > 1 And bas = Split(stokKodu, ":")(1) Then
Rows(iRow + 1).Delete
Exit Do
End If
fiyat = Replace(html2.querySelector(".spanFiyat").innerText, " TL", "")
Cells(iRow + 1, 2) = fiyat * 1
Cells(iRow + 1, 2).NumberFormat = "#,##0.00"
End If
End If
Next
End If
syf = syf + 1
DoEvents
Loop
'-------------------------------------------------------------------------------------------------------
Cells.EntireColumn.AutoFit
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.EnableEvents = True
MsgBox "İşlem tamamlandı." & Chr(10) _
& Format(Timer - Zaman, "0.00")
End Sub
