438 ошибка VBA Excel соскоб с гиперссылок - PullRequest
Новая
       18

438 ошибка VBA Excel соскоб с гиперссылок

0 голосов
/ 25 апреля 2018

У меня есть код ниже, так как я пытаюсь соскрести текст с некоторых веб-страниц.В настоящее время я настроил Excel таким образом, что я вставил гиперссылку в столбец A, и он циклически перебирает и вытягивает весь текст с веб-страницы в Excel.Тем не менее, я получаю

438 ошибку

в строке ie.document.body.innertext.

Кто-нибудь знает, почему это может происходить?Я немного обыскал, но не добился большого успеха, так как кажется, что это довольно распространенная проблема, но со многими различными причинами.Любая помощь будет принята с благодарностью, и заранее извиняюсь за все очевидное, так как я довольно новичок в VBA.

Sub Sample()
Dim ie As Object
Dim retStr As String
Dim sht As Worksheet
Dim LastRow As Long
Dim rCell As Range
Dim rRng As Range

Set sht = ThisWorkbook.Worksheets("Sheet1")

'Ctrl + Shift + End
LastRow = sht.Cells(sht.Rows.Count, "A").End(xlUp).Row

Set ie = CreateObject("internetexplorer.application")


Set rRng = Sheet1.Range("A1:A" & LastRow)

For Each rCell In rRng.Cells

        With ie
            .Navigate rCell.Value
            .Visible = True
        End With

        Do While ie.readystate <> 4: Wait 5: Loop
        DoEvents

        rCell.Offset(0, 1).Value = ie.document.body.innerText
Next rCell

End Sub

Private Sub Wait(ByVal nSec As Long)
nSec = nSec + Timer
While nSec > Timer
    DoEvents
Wend
End Sub

1 Ответ

0 голосов
/ 25 апреля 2018

Вам действительно нужен IE, чтобы сделать работу? Может, лучше попробовать HTTP-запрос? 

Dim xHttp As MSXML2.XMLHTTP
Dim hDoc As MSHTML.HTMLDocument

Set rRng = Sheet1.Range("A1:A" & LastRow)

For Each rCell In rRng.Cells
    Set xHttp = New MSXML2.XMLHTTP
    xHttp.Open "GET", rCell.Value
    xHttp.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    xHttp.send

    Do Until xHttp.READYSTATE = 4
        DoEvents
    Loop

    If xHttp.Status = 200 Then
        rCell.Offset(0, 1).Value = xHttp.responseText
    End If
Next rCell
...