Блог

Друзья, я новичок в VBA, и здесь я пытаюсь очистить данные с внутреннего веб-сайта. Процесс происходит следующим образом: в столбце A3 до конца введено несколько серийных номеров. Предполагается, что макрос перейдет к URL-адресу -> выберите серийный номер из Excel -> Введите в поле поиска и нажмите Поиск. Как только результат заполняется на странице, он очищает определенные значения и заполняет таблицу Excel.

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

 Sub Type1_Data()
    Dim ie As InternetExplorer
    Dim html As MSHTML.HTMLDocument
    Dim RowNumber, ColumnNumber As Long
    RowNumber = 3
    ColumnNumber = 0

    Dim i As Long
    Dim HTMLDoc As MSHTML.HTMLDocument
    Dim Filt As MSHTML.IHTMLElement
    Dim mtbl As MSHTML.IHTMLElement
    Dim strempid As MSHTML.HTMLElementCollection
    Dim strempid1 As MSHTML.HTMLElementCollection
    Dim strempid2 As MSHTML.HTMLElementCollection
    Dim strempid3 As MSHTML.HTMLElementCollection
    Dim strempid4 As MSHTML.HTMLElementCollection
    Dim strempid5 As MSHTML.HTMLElementCollection
    Dim strempid6 As MSHTML.HTMLElementCollection

    Set ie = New InternetExplorer
    ie.Visible = False
    ie.navigate ("URL")

    Do While ie.READYSTATE = 4: DoEvents: Loop
    Do Until ie.READYSTATE = 4: DoEvents: Loop
    Set HTMLDoc = ie.document
xy:
    If HTMLDoc.Title <> "Marketplace | Find a professional" Then
        ie.Visible = True
    
        GoTo xy
    End If
    ie.Visible = True
    ThisWorkbook.Activate
    Dim Ed As Integer
    Ed = 3
    While ThisWorkbook.Sheets("ProM Search").Cells(Ed, 1).Value <> 0
        Ed = Ed   1
    Wend
    Ed = Ed - 1
    For i = 3 To Ed
        Application.ScreenUpdating = True
        Set UID = HTMLDoc.getElementById("navSelect")
        Set Filt = HTMLDoc.getElementById("searchText")
        Set mtbl = HTMLDoc.getElementsByTagName("Table")(23)
        Application.Wait DateAdd("s", 1, Now)
        HTMLDoc.getElementById("NLQTextArea").Value = ThisWorkbook.Sheets("ProM Search").Cells(i, 1).Value
        HTMLDoc.getElementById("submitAction").Click

        Set strempid = mtbl.getElementsByClassName("dojoxGridCell")(1)
        Set strempid1 = mtbl.getElementsByClassName("dojoxGridCell")(2)
        Set strempid2 = mtbl.getElementsByClassName("dojoxGridCell")(3)
        Set strempid3 = mtbl.getElementsByClassName("dojoxGridCell")(7)
        Set strempid4 = mtbl.getElementsByClassName("dojoxGridCell")(9)
        Set strempid5 = mtbl.getElementsByClassName("dojoxGridCell")(11)
        Set strempid6 = mtbl.getElementsByClassName("dojoxGridCell")(12)

        ActiveCell.Offset(0, 1).Activate
        ActiveCell.Value = strempid.innerText
        ActiveCell.Offset(0, 1).Activate
        ActiveCell.Value = strempid1.innerText
        ActiveCell.Offset(0, 1).Activate
        ActiveCell.Value = strempid2.innerText
        ActiveCell.Offset(0, 1).Activate
        ActiveCell.Value = strempid3.innerText
        ActiveCell.Offset(0, 1).Activate
        ActiveCell.Value = strempid4.innerText
        ActiveCell.Offset(0, 1).Activate
        ActiveCell.Value = strempid5.innerText
        ActiveCell.Offset(0, 1).Activate
        ActiveCell.Value = strempid6.innerText
        ActiveCell.Offset(1, -7).Activate
        DoEvents
        If ActiveCell.Value = "" Then
            MsgBox "Fetching Completed Successfully", vbExclamation, "ProM - Open Seat Search T2"
            GoTo qt
        End If
    Next

qt:
    ie.Quit
    Set ie = Nothing
    Set HTMLDoc = Nothing

End Sub
  

HTMLDoc.getElementById("submitAction").Click может привести к обновлению страницы, из-за чего любые элементы, на которые ссылаются, становятся устаревшими. Попробуйте всегда работать с ie.document , а не устанавливать в переменную при выполнении действий, которые, как вероятно / известно, вызывают обновление страницы. Это распространенная причина ошибки отказа в разрешении.

Вероятно, у вас If End If должен быть цикл с тайм-аутом. Вам нужен только один ie.visible = True . На мой взгляд, вы редко выигрываете от настройки Visible на false. Если вы собираетесь скрыть это от пользователя, вы должны сделать это с самого начала, если это не мешает функциональности.

Нет смысла Application.ScreenUpdating = True , поскольку он никогда не отключается в этом подразделении. Если этот подраздел вызывается, то он нужен только один раз вне цикла. Ваш повторный ActiveCell.Offset(0, 1).Activate может просто использовать цикл с Select Case и установить значение напрямую без активации. Повторение строки Do While ie.READYSTATE = 4: DoEvents: Loop не имеет смысла.

Вы могли бы использовать Find метод range для определения строки в столбце 1, где встречается 0, вместо того, чтобы идти вниз по столбцу. И тесты для определения этого найдены и > = 3.

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

Кроме того, вы также можете обратиться к моему рабочему образцу о чтении значения ячейки в VBA:

 Sub LOADIE()
    Set ieA = CreateObject("InternetExplorer.Application")
    ieA.Visible = True
    ieA.navigate "https://www.bing.com"
    Do Until ieA.readyState = 4
       DoEvents
    Loop
    Set doc = ieA.Document
    Dim tempStr As String
    tempStr = "sb_form_q"
    doc.getElementById(tempStr).Value = ThisWorkbook.Sheets("SheetName").Range("E2").Value
End Sub