Селен VBA извлечения данных из веб-таблицы последний бит кода для копирования текста не работает

Question

Я пытался импортировать результаты таблицы из http://avionictools.com/icao.php используя пример кода Reg является N2 мой код добавляет код Reg и нажимает кнопку отправки, но я не могу скопировать результаты из таблицы. Я хотел скопировать шестнадцатеричный код в столбец C

Public Sub regsearch()
Dim LR1, lr2 As Long, i As Long

LR1 = Sheet1.Range("A" & Rows.Count).End(xlUp).Row



Dim data As String

Dim bot As New WebDriver
For i = 2 To 2
Sheet1.Range("A" & i).Copy 'Value is N2

Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
        With clipboard
            .GetFromClipboard
            data = .getText
        End With
        'MsgBox data
bot.Start "chrome", "http://avionictools.com"


bot.Wait 2000
bot.get "/icao.php"
bot.Wait 2000


bot.FindElementByName("data").Click

bot.SendKeys data
bot.Wait 2000
bot.FindElementByXPath("//div/input").Click



bot.Wait 1000


Set Table = bot.getElementsByTagName("table").Item(0)
For Each Tr In Table.getElementsByTagName("tr")
    tdlen = Tr.getElementsByTagName("td").Length
If tdlen > 1 Then
    lr = Sheet2.Range("A" & Rows.Count).End(xlUp).Row + 1
    Sheet1.Range("C" & i).Value = Tr.getElementsByTagName("td").Item(0).innerText
    Sheet1.Range("D" & i).Value = Tr.getElementsByTagName("td").Item(1).innerText
Else

    End If


Next Tr
Application.Wait Now + TimeValue("00:00:04")


Next
End Sub

Answer 1

Мне кажется, что работает следующее

Option Explicit

Public Sub GetInfo()
    Dim IE As New InternetExplorer, clipboard As Object, ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set clipboard = GetObject("New:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")

    With IE
        .Visible = True
        .navigate "http://www.airlinecodes.co.uk/airlcodesearch.asp" '"http://www.airlinecodes.co.uk/airlcoderes.asp"

        While .Busy Or .readyState < 4: DoEvents: Wend

        .document.querySelector("[name=icaocode]").Value = "BAW"
        .document.querySelector("[name=submit]").Click

        While .Busy Or .readyState < 4: DoEvents: Wend

        clipboard.SetText .document.querySelectorAll("table").item(4).outerHTML '.getAttribute("outerHTML")
        clipboard.PutInClipboard

        .Quit
    End With

    ws.Cells(1, 1).PasteSpecial

End Sub

---

Редактировать:

В ответ на ваш измененный вопрос:

Option Explicit
Public Sub test()
    Dim bot As New ChromeDriver, ws As Worksheet, text As String, i As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    With bot
        .Start
        .get "http://avionictools.com/icao.php"
        For i = 1 To 2
        .FindElementByCss("input[name=data]").SendKeys "N" & CStr(i)
        .FindElementByCss("[type=submit]").submit

        text = .FindElementsByTag("table")(1).FindElementsByTag("tr")(2).FindElementsByTag("td")(1).text
        ws.Cells(i, 1) = Split(text, Chr$(10))(1)
        .FindElementByCss("input[name=data]").Clear
        Next
        .Quit
    End With
End Sub

Answer 2

Странно встретить эту ошибку, но вы можете исправить ее, сбросив объект IE.

For i = 2 To 2

    IE.navigate "http://www.airlinecodes.co.uk/airlcodesearch.asp"
    Do
        DoEvents
        Set IE = GetIE("airlinecodes.co.uk")
    Loop While IE.readyState < READYSTATE_COMPLETE
    Set DOC = IE.document
    DoEvents
    DOC.getElementsByName("icaocode").Item(0).Value = Sheet1.Range("A" & i).Value
    For Each inpt In DOC.getElementsByTagName("input")
        If inpt.Name = "submit" And inpt.Type = "submit" And inpt.Value = "Submit" Then
            inpt.Click
            Do
                DoEvents
                Set IE = GetIE("airlinecodes.co.uk")
            Loop While IE.readyState < READYSTATE_COMPLETE
            Exit For
        End If
    Next inpt

Я обновил два цикла здесь, используя

Do
    DoEvents
    Set IE = GetIE("airlinecodes.co.uk")
Loop While IE.readyState < READYSTATE_COMPLETE

Это означает, что вы будете запускать этот цикл как минимум один раз, так как я переместил оператор While вниз - он будет постоянно сбрасывать ваш IE объект до загрузки страницы - опять же, это не то, с чем вы всегда будете сталкиваться при просмотре веб-страниц, хотя это, конечно, странно.

Вам также необходимо добавить следующую подпрограмму в свой модуль - это то, что собирается сбросить ваш IE объект:

Function GetIE(sLocation As String) As InternetExplorer

    Dim objShell As Object, objShellWindows As Object, o As Object
    Dim sURL As String
    Dim RetVal As InternetExplorer

    Set RetVal = Nothing
    Set objShell = CreateObject("shell.application")
    Set objShellWindows = objShell.Windows

    For Each o In objShellWindows
        sURL = ""
        On Error Resume Next
        sURL = o.document.Location
        On Error GoTo 0
        If sURL Like "*" & sLocation & "*" Then
            Set RetVal = o
            Exit For
        End If
    Next o

    Set GetIE = RetVal

End Function