Соскоб из VBA с запросом на выборку

Question

Я использовал код с этого сайта для получения данных с сайта :

Option Explicit
Public Sub GetInfo()
    Dim sResponse As String, i As Long, Html As New HTMLDocument
    Dim prices As Object, info As Object
    Application.ScreenUpdating = False
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://bazashifer.ru/proflist-profnastil", False
        .send
        sResponse = .responseText
    End With
    With Html
        .body.innerHTML = sResponse
        Set info = .querySelectorAll("div.views-field.views-field-title")
        Set prices = .querySelectorAll("div.views-field.views-field-field-cena-tovara")
    End With
    With Worksheets(2)
        For i = 0 To info.Length - 1
            .Cells(i + 1, 1) = info(i).innerText
            .Cells(i + 1, 2) = prices(i).innerText
        Next i
    End With
    Application.ScreenUpdating = True
End Sub

Код выше работает так, как задумано. Я реализовал код для получения нескольких ссылок ( ссылка 1 , ссылка 2 , ссылка 3 ):

Option Explicit
Public Sub GetInfoAll()
Dim wsSheet As Worksheet, Rows As Long, http As New XMLHTTP60, Html As New HTMLDocument, links As Variant, link As Variant
Dim prices As Object, info As Object, i As Long, sResponse As String
Set wsSheet = Sheets(1)
Rows = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).row
links = wsSheet.Range("A1:A" & Rows)
    With http
    For Each link In links
        .Open "GET", link, False
        .send
         sResponse = .responseText
        With Html
        .body.innerHTML = sResponse
        Set info = .querySelectorAll("div.views-field.views-field-title")
        Set prices = .querySelectorAll("div.views-field.views-field-field-cena-tovara")
    End With
    With Worksheets(2)
        For i = 0 To info.Length - 1
            .Cells(i + 1, 1) = info(i).innerText
            .Cells(i + 1, 2) = prices(i).innerText
        Next i
    End With
   Next link
 End With
End Sub

Приведенный выше код работает и должен вытянуть данные в столбцы, но для следующей ссылки код перезаписывает данные. Любая помощь будет отличной. Спасибо

Answer 1

Rows = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).row

Вам нужно иметь что-то подобное во время вывода l oop на листе 2, потому что вы не можете жестко указать количество результатов.

Отредактируйте вот что я действительно имел в виду вывод

Public Sub GetInfoAll()
Dim wsSheet As Worksheet, Rows As Long, http As New XMLHTTP60, Html As New HTMLDocument, links As Variant, link As Variant
Dim prices As Object, info As Object, i As Long, sResponse As String, offsetRows As Long

Dim wb As Workbook
Set wb = Application.Workbooks("Book1")
Set wsSheet = wb.Sheets(1)
Rows = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
links = wsSheet.Range("A1:A" & Rows)
    With http
    For Each link In links
        .Open "GET", link, False
        .send
         sResponse = .responseText
        With Html
        .body.innerHTML = sResponse
        Set info = .querySelectorAll("div.views-field.views-field-title")
        Set prices = .querySelectorAll("div.views-field.views-field-field-cena-tovara")
    End With
    With wb.Worksheets(2)
        For i = 0 To info.Length - 1
            offsetRows = 0
            offsetRows = wb.Worksheets(2).Cells(wb.Worksheets(2).Rows.Count, "A").End(xlUp).Row + 1
            .Cells(offsetRows, 1) = info(i).innerText
            .Cells(offsetRows, 2) = prices(i).innerText
        Next i
    End With
   Next link
 End With
End Sub

Answer 2

Я думаю, что идеально использовать контейнер, а затем пропустить через него oop, чтобы проанализировать желаемое содержимое. Рассмотрим следующий пример. Вы всегда можете добавить остальные в соответствии с вашими потребностями.

Public Sub GetInfo()
    Dim Html As New HTMLDocument, Htmldoc As New HTMLDocument
    Dim Wb As Workbook, ws As Worksheet, R&, I&
    Dim link As Variant, linklist As Variant

    Set Wb = ThisWorkbook
    Set ws = Wb.Worksheets("output")

    linklist = Array( _
        "https://bazashifer.ru/armatura-stekloplastikovaya", _
        "https://bazashifer.ru/truby-0", _
        "https://bazashifer.ru/setka-stekloplastikovaya" _
       )

    For Each link In linklist
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", link, False
            .send
            Html.body.innerHTML = .responseText
        End With

        With Html.querySelectorAll(".view-content > .views-row")
            For I = 0 To .Length - 1
                Htmldoc.body.innerHTML = .item(I).outerHTML
                R = R + 1: ws.Cells(R, 1) = Htmldoc.querySelector(".views-field-title a").innerText
                ws.Cells(R, 2) = Htmldoc.querySelector("[class*='cena-tovara'] > .field-content").innerText
            Next I
        End With
    Next link
End Sub

Answer 3

Мне кажется, проблема в том, что ваши столбцы не обновляются для каждой ссылки.

    For i = 0 To info.Length - 1
        .Cells(i + 1, 1) = info(i).innerText
        .Cells(i + 1, 2) = prices(i).innerText
    Next i

В этой части вы записываете все в первый и второй столбцы. Это должно обновляться каждый раз, когда вы переходите на новую ссылку.

Так что, возможно, добавьте переменную 'colcount', которая обновляется непосредственно перед переходом к следующей ссылке?

что-то вроде этого:

Infocol = 1
Pricecol = 2
For Each link In links

....

.Cells(i + 1, Infocol) = info(i).innerText
.Cells(i + 1, Priceol) = prices(i).innerText


....

Infocol = infocol + 2
Pricecol = Pricecol + 2
Next link

Вы go +2, поэтому вы не перезаписываете свой ценовой столбец новой информацией.