Попытка импортировать данные с нескольких URL-адресов, но всегда застревает на первом URL-адресе

Question

Думаю, я иду по ложному пути, и теперь я действительно сбился с курса. Я пытаюсь l oop через 93 URL-адреса и импортировать данные из каждого. Вот код, который я тестирую.

Sub Web_Table()
    Dim HTMLDoc As New HTMLDocument
    Dim objTable As Object
    Dim lRow As Long
    Dim lngTable As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim ActRw As Long
    Dim objIE As InternetExplorer
    Set objIE = New InternetExplorer
    
    Dim sht As Worksheet
    Dim LastRow As Long
    Set sht = ActiveSheet
    lngRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

    For i = 1 To 93
    
        objIE.Navigate "https://etfdb.com/screener/#tab=returns&page=" & i
    
        Do Until objIE.ReadyState = 4 And Not objIE.Busy
            DoEvents
        Loop
        
        'Application.Wait (Now + TimeValue("0:00:03")) 'wait for java script to load
        
        HTMLDoc.body.innerHTML = objIE.Document.body.innerHTML
        With HTMLDoc.body
            Set objTable = .getElementsByTagName("table")
            For lngTable = 0 To objTable.Length - 1
                For lngRow = 0 To objTable(lngTable).Rows.Length - 1
                    For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
                        ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
                    Next lngCol
                Next lngRow
                ActRw = ActRw + objTable(lngTable).Rows.Length + 1
            Next lngTable
        End With
        
        Debug.Print i
        lngRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row
        
    Next i
    
    objIE.Quit
    
End Sub

Я ожидаю увидеть это из первого URL:

Symbol  ETF Name    1 Week  4 Week  YTD 1 Year  3 Year  5 Year  Returns Rating
SPY SPDR S&P 500 ETF    -2.44%  7.19%   -2.19%  10.36%  36.10%  65.39%  
IVV iShares Core S&P 500 ETF    -2.46%  7.20%   -2.22%  10.48%  36.60%  65.41%  
VTI Vanguard Total Stock Market ETF -2.45%  7.88%   -2.58%  9.38%   33.94%  60.89%  
etc.

Затем это из второго URL:

Symbol  ETF Name    1 Week  4 Week  YTD 1 Year  3 Year  5 Year  Returns Rating
VGT Vanguard Information Technology ETF 0.15%   8.00%   11.98%  34.51%  98.99%  168.56% 
XLK Technology Select Sector SPDR Fund  0.11%   7.44%   12.41%  36.64%  92.76%  161.90% 
etc.    

И, далее, это из третьего URL:

Symbol  ETF Name    1 Week  4 Week  YTD 1 Year  3 Year  5 Year  Returns Rating
IXUS    iShares Core MSCI Total International Stock ETF -2.42%  9.27%   -10.66% -0.97%  4.29%   12.08%  
SCHF    Schwab International Equity ETF -2.48%  9.96%   -10.05% -0.66%  4.24%   11.43%  
etc.    

По какой-то странной причине кажется, что он застрял на первом URL и никогда не переходит на второй, третий и т. Д. c. У меня есть objIE.Navigate и Do Until objIE.ReadyState = 4 And Not objIE.Busy. Чего я здесь не вижу?

Answer 1

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

Я сделал это на Windows 10 64-битной ОС с Excel 2016.

Вы можете увидеть значение переменной 'i', которое вы напечатали в консоли.

Я видел такую ​​проблему с VBA IE код автоматизации застревает в строке ReadyState.

Чтобы подтвердить эту проблему, вы можете попытаться установить точку останова в своем коде, и вы заметите, что код будет постоянно l oop для ReadyState и никогда заканчивается.

Если вы попытаетесь запустить тот же код на любом другом компьютере, вы можете заметить, что код будет работать нормально. Например, код работает у меня.

Затем вы также можете попробовать протестировать с приведенными ниже примерами кода, чтобы увидеть, что любой из них работает для вас.

  With objIE
        Do While .Busy Or .ReadyState <> 4: DoEvents: Loop
    End With

  '----------------OR---------------------------------------

    Do While objIE.Busy = True
    Loop
  '----------------OR---------------------------------------
    Do While objIE.readyState = 4: DoEvents: Loop
    Do Until objIE.readyState = 4: DoEvents: Loop
    While objIE.Busy
         DoEvents
    Wend

Если ничего не работает, попробуйте чтобы протестировать Application.wait еще несколько секунд.

Application.Wait (Now + TimeValue("0:00:05"))

Вы также можете сделать тест с функцией сна.

#If VBA7 Then ' Excel 2010 or later

    Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)

#Else ' Excel 2007 or earlier

    Public Declare Sub Sleep Lib "kernel32" (ByVal Milliseconds As Long)

Sub demo()
   For i = 0 To 10
       DoEvents
           Sleep 1000
           Debug.Print i
   Next i
End Sub

Полезная ссылка на поток:

internetexplorer.application висит на readystate = 1 в VBA

Answer 2

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

Лично, если очистка разрешена, я бы переключился на xmlhttp, чтобы избежать проблемы с синхронизацией. Вы можете изменить per_page и получить больше результатов с меньшим количеством запросов. Вот пример:

Вам понадобится парсер json, такой как jsonconverter.bas, для синтаксического анализа возвращенного json в таблицу, если это необходимо.

Option Explicit

Public Sub GetData()
    Dim xhr As MSXML2.xmlhttp60, html As MSHTML.HTMLDocument, body As String
    'required VBE (Alt+F11) > Tools > References > Microsoft HTML Object Library ;  Microsoft XML, v6 (your version may vary)

    Set xhr = New MSXML2.xmlhttp60
    Set html = New MSHTML.HTMLDocument

    body = "{""tab"":""returns"",""page"":pageNumber,""per_page"":1000}"

    With xhr
        Dim page As Long
        For page = 1 To 2
            .Open "POST", "https://etfdb.com/api/screener/", False
            .setRequestHeader "User-Agent", "Mozilla/5.0"
            .setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
            .send Replace$(body, "pageNumber", page)
            'debug.Print .Status
            ActiveSheet.Cells(page, 1) = .responseText
        Next
    End With

End Sub