VBA HTML Pull необходимо ускорить

Question

У меня есть следующий код, который работает (спасибо всем за вашу помощь!), Но он работает относительно медленно. Требуется приблизительно 20-25 минут, чтобы пройти приблизительно 1000 ссылок.

Это немного долго, чтобы эффективно его использовать (хотя я понимаю, что открытие и очистка 1000 списков занимает время) - есть ли способ сократить это?

В идеале я хотел бы получить информацию из более чем 10 тыс. Ссылок.

Public Sub ListingInfo()
Dim cell As Range
With ThisWorkbook.Worksheets("eBayListings")
    For Each cell In .Range("A1", .Cells(.Rows.count, 1).End(xlUp))
        Dim Document As MSHTML.HTMLDocument
        Dim elem As MSHTML.IHTMLElement
        Dim elem2 As MSHTML.IHTMLElement
        With CreateObject("MSXML2.XMLHTTP")
            .Open "GET", cell.Value, False
            .send
            Set Document = New MSHTML.HTMLDocument
            Document.body.innerHTML = .responseText
        End With
        Set elem2 = Document.getElementById("itemTitle")
        If Not elem2 Is Nothing Then
        cell.Offset(0, 1).Value = elem2.innerText
        Else
        End If
        Set elem2 = Document.getElementById("vi-cdown_timeLeft")
        If Not elem2 Is Nothing Then
        cell.Offset(0, 2).Value = elem2.innerText
        Else
        End If
        Set elem = Document.getElementById("prcIsum_bidPrice")
        If Not elem Is Nothing Then
        cell.Offset(0, 3).Value = elem.innerText
        Else
        End If
        Set elem = Document.getElementById("prcIsum")
        If Not elem Is Nothing Then
        cell.Offset(0, 4).Value = elem.innerText
        Else
        End If
        Set elem2 = Document.getElementById("mbgLink")
        If Not elem2 Is Nothing Then
        cell.Offset(0, 5).Value = elem2.innerText
        Else
        End If
        Set elem2 = Document.getElementById("si-fb")
        If Not elem2 Is Nothing Then
        cell.Offset(0, 6).Value = elem2.innerText
        Else
        End If
        Set elem2 = Document.getElementById("binBtn_btn")
        If Not elem2 Is Nothing Then
        cell.Offset(0, 7).Value = elem2.innerText
        Else
        End If
        Set elem2 = Document.getElementById(".ds_div")
        If Not elem2 Is Nothing Then
        cell.Offset(0, 8).Value = elem2.innerText
        Else
        End If
        If Not Document.querySelector(".viSNotesCnt") Is Nothing Then
            cell.Offset(0, 9).Value = Document.querySelector(".viSNotesCnt").innerText
        Else
            'Try Something Else
        End If
    Next
End With
End Sub

Answer 1

Комментарий относительно регулирования является важным. Возможно, вам придется добавить несколько ожиданий. Один из методов может состоять в том, чтобы поддерживать количество посещенных URL-адресов, и каждое число х вводит ожидание.

Для вышеперечисленного вы можете сбрить время, избегая попадания на лист каждый раз, чтобы получить доступ к значениям и выписать их. Вместо этого сохраните URL в массиве и зациклите это. Сохраняет результаты каждого цикла в массиве. Записать весь массив результатов за один раз в конце.

Переместить создание объекта xmlhttp из цикла. Переключатель обновления экрана и любой другой оптимизации приложения / листа по вашему желанию.

Потенциально уменьшите количество строк кода, как показано ниже.

Возможно, вы захотите добавить тест, если в листе присутствует только один URL-адрес, и в этом случае вам нужно будет переопределить массив URL-адресов, чтобы предотвратить ошибку, и просто назначить прямой из заполненной ячейки в массив.

Не тестировалось.

Option Explicit
Public Sub ListingInfo()
    Dim Document As MSHTML.HTMLDocument, urls(), url As String, results()
    Set Document = New MSHTML.HTMLDocument
    Application.ScreenUpdating = False
    With ThisWorkbook.Worksheets("eBayListings")
        urls = .Range("A1", .Cells(.Rows.Count, 1).End(xlUp)).Value
        ReDim results(1 To UBound(urls, 1), 1 To 9)
        With CreateObject("MSXML2.XMLHTTP")
            For url = LBound(urls, 1) To UBound(urls, 1)
                .Open "GET", urls(url), False
                .send
                Document.body.innerHTML = .responseText
                On Error Resume Next
                With Document
                    results(url, 1) = .getElementById("itemTitle").innerText
                    results(url, 2) = .getElementById("vi-cdown_timeLeft").innerText
                    results(url, 3) = .getElementById("prcIsum_bidPrice").innerText
                    results(url, 4) = .getElementById("prcIsum").innerText
                    results(url, 5) = .getElementById("mbgLink").innerText
                    results(url, 6) = .getElementById("si-fb").innerText
                    results(url, 7) = .getElementById("binBtn_btn").innerText
                    results(url, 8) = .getElementById(".ds_div").innerText '<== is this id correct
                    results(url, 9) = .querySelector(".viSNotesCnt").innerText
                    'any tests on current row (url) for empty.......
                End With
                On Error GoTo 0
            Next
        End With
        .Cells(1, 2).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
    Application.ScreenUpdating = True
End Sub