VBA Xml Loop

[jamescooper]

Hello following code works fine for 1 URL, I am trying to adapt so it runs for all the numerical pages it can find from the baseURL, so for instance the 1 up to the max until there is an error, is this possible?

Thanks.

baseUrl = "https://www.tesco.com/groceries/en-GB/shop/fresh-food/all?include-children=true&page=1"

Public Sub Data_Pull_Products_and_Prices()


Dim http As Object, html As New HTMLDocument, topics As Object, topics2 As Object, titleElem As Object, topic As HTMLHtmlElement
Dim i As Integer
Dim j As Integer


Set http = CreateObject("MSXML2.XMLHTTP")


baseUrl = "https://www.tesco.com/groceries/en-GB/shop/fresh-food/all?include-children=true&page=1"


URL = URL = baseURL &
http.Open "GET", "https://www.tesco.com/groceries/en-GB/shop/fresh-food/all?include-children=true&page=1", False
http.send
html.body.innerHTML = http.responseText


Set topics = html.getElementsByClassName("product-details--wrapper")
Set topics2 = html.getElementsByClassName("price-control-wrapper")


i = 1


For Each topic In topics
Set titleElem = topic.getElementsByTagName("div")(0)
Sheets(1).Cells(i, 1).Value = titleElem.getElementsByTagName("a")(0).innerText


i = i + 1


Next


j = 1


For Each topic In topics2
Set titleElem = topic.getElementsByTagName("div")(0)
Sheets(1).Cells(j, 2).Value = titleElem.getElementsByTagName("span")(0).innerText


j = j + 1


Next


End Sub

 

[jamescooper]

Got the loop working - now how do I prevent it from pasting over the top of the previous data?

Thanks.

Public Sub Data_Pull_Products_and_Prices()


Dim http As Object, html As New HTMLDocument, topics As Object, topics2 As Object, titleElem As Object, topic As HTMLHtmlElement
Dim i As Integer
Dim j As Integer
Dim rngURL As Range


Set http = CreateObject("MSXML2.XMLHTTP")


For Each rngURL In Worksheets("Sheet1").Range("E1", Worksheets("Sheet1").Range("E" & Rows.Count).End(xlUp))


http.Open "GET", rngURL, False
http.send
html.body.innerHTML = http.responseText


Set topics = html.getElementsByClassName("product-details--wrapper")
Set topics2 = html.getElementsByClassName("price-control-wrapper")


i = 1


For Each topic In topics
Set titleElem = topic.getElementsByTagName("div")(0)
Sheets(1).Cells(i, 1).Value = titleElem.getElementsByTagName("a")(0).innerText


i = i + 1


Next


j = 1


For Each topic In topics2
Set titleElem = topic.getElementsByTagName("div")(0)
Sheets(1).Cells(j, 2).Value = titleElem.getElementsByTagName("span")(0).innerText


j = j + 1


Next


Next


End Sub

 

[jamescooper]

Any ideas here on how to manipulate i, to not allow the data to paste over the previous?

Thanks.

 

[jamescooper]

Many to solve it.

Public Sub Data_Pull_Products_and_Prices_2()


Dim http As Object, html As New HTMLDocument, topics As Object, topics2 As Object, titleElem As Object, topic As HTMLHtmlElement
Dim i As Integer
Dim j As Integer
Dim rngURL As Range
Dim LastRow As Long
Dim LastRow2 As Long


Application.ScreenUpdating = False


Set http = CreateObject("MSXML2.XMLHTTP")


For Each rngURL In Worksheets("Sheet1").Range("E1", Worksheets("Sheet1").Range("E" & Rows.Count).End(xlUp))


http.Open "GET", rngURL, False
http.send
html.body.innerHTML = http.responseText


DoEvents


Set topics = html.getElementsByClassName("product-details--wrapper")
Set topics2 = html.getElementsByClassName("price-control-wrapper")


i = 1


For Each topic In topics
Set titleElem = topic.getElementsByTagName("div")(0)
Sheets(1).Cells(i, 1).Value = titleElem.getElementsByTagName("a")(0).innerText
LastRow = Cells(Rows.Count, "A").End(xlUp).Row
i = 1 + LastRow


Next


j = 1


For Each topic In topics2
Set titleElem = topic.getElementsByTagName("div")(0)
Sheets(1).Cells(j, 2).Value = titleElem.getElementsByTagName("span")(0).innerText
LastRow2 = Cells(Rows.Count, "B").End(xlUp).Row
j = 1 + LastRow2


Next


Next


Application.ScreenUpdating = True


End Sub