Я бы сделал это, как показано ниже.Это решение написано с учетом ваших будущих циклов на нескольких DOTNum.Я проверил цикл с 3 числами, и он отлично работает.
Метод доступа:
Я использую запрос XMLHTTP как гораздо более быстрый метод поиска, чем запуск IE.
Информация о регистрации:
Информация о регистрации, которую я получаю, применяя селектор класса CSS к целевым элементам с классом .dat.Затем я индексирую в nodeList, возвращаемом querySelectorAll, для получения требуемых элементов.
Разбивка по типу транспортного средства:
Полная таблица разбивки по типу транспортного средства, которую я первоначально получаюпо индексу и тегу с .getElementsByTagName("table")(0).
Таблица имеет немного хитрое расположение.Например, элементы первого столбца на самом деле помечены th, а не td.Я обхожу это, сначала изолируя фактические заголовки с помощью селекторной комбинации CSS-потомков thead th.Это предназначается только для элементов th в заголовке таблицы.Затем я использую оператор CSS OR в комбинации селекторов CSS-потомков, чтобы получить обратно элементы первого столбца th или оставшиеся элементы столбца td с тегами: tbody tr th,td.Я использую mod 4, чтобы определить, является ли это первый столбец или нет, и соответствующим образом настроить запись в новую строку.
Помощники (модульный код рекомендуется):
Я использовал вспомогательную функцию GetLastRow, чтобы определить, с чего начать запись, так как похоже, что вы в конечном итоге развернете это в цикле на разных DOTnums.Я использую класс для хранения объекта XMLHTTP.
WriteTable делает это говорит.Он записывает таблицу.
dotNums:
Я считал dotNums из листа с именем DOTNumbers.В моем примере я использую 3 числа, чтобы получить информацию для {529136,621247,2474795}.Массив dotNums заполняется этими значениями из листа и зацикливается, чтобы обеспечить добавление dotNum в URL.
Пример оператора OR в запросе CSS(образец):
Пример вывода:
VBA:
Модуль класса clsHTTP:
Option Explicit
Private http As Object
Private Sub Class_Initialize()
Set http = CreateObject("MSXML2.XMLHTTP")
End Sub
Public Function GetString(ByVal url As String) As String
Dim sResponse As String
With http
.Open "GET", url, False
.setRequestHeader "If-Modified-Since", "Sat, 1 Jan 2000 00:00:00 GMT"
.send
sResponse = StrConv(.responseBody, vbUnicode)
GetString = sResponse
End With
End Function
Стандартный модуль 1:
Option Explicit
Public Sub GetInfo()
Dim html As HTMLDocument, headers1(), hTable As HTMLTable
Dim ws As Worksheet, wsDotNums As Worksheet, registrationinfo As Object, nextRow As Long
Dim dotNums(), http As clsHTTP, url As String, i As Long
Application.ScreenUpdating = True
Set http = New clsHTTP
Set ws = ThisWorkbook.Worksheets("Sheet1")
Set wsDotNums = ThisWorkbook.Worksheets("DOTNumbers")
Set html = New HTMLDocument
dotNums = Application.Transpose(wsDotNums.Range("A1:A3").Value) '<== Change the range here to the single column range containing your dotNums.
For i = LBound(dotNums) To UBound(dotNums)
If Not IsEmpty(dotNums(i)) Then
With html
url = "https://ai.fmcsa.dot.gov/SMS/Carrier/" & dotNums(i) & "/CarrierRegistration.aspx"
html.body.innerHTML = http.GetString(url)
Set registrationinfo = .querySelectorAll(".dat")
Set hTable = .getElementsByTagName("table")(0)
End With
headers1 = Array("Legal Name", "Address", "Miles Traveled ", "Email")
nextRow = IIf(GetLastRow(ws, 1) = 1, 1, GetLastRow(ws, 1) + 2)
With ws
.Cells(nextRow, 1).Resize(1, UBound(headers1) + 1) = headers1
.Cells(nextRow + 1, 1) = registrationinfo.item(0).innerText
.Cells(nextRow + 1, 2) = registrationinfo.item(3).innerText
.Cells(nextRow + 1, 3) = registrationinfo.item(7).innerText
.Cells(nextRow + 1, 4) = registrationinfo.item(6).innerText
End With
WriteTable hTable, nextRow + 3, ws
End If
Next
Application.ScreenUpdating = True
End Sub
Public Sub WriteTable(ByVal hTable As HTMLTable, Optional ByVal startRow As Long = 1, Optional ByVal ws As Worksheet)
If ws Is Nothing Then Set ws = ActiveSheet
Dim r As Long, c As Long, i As Long, headers As Object
r = startRow
With ws
Set headers = hTable.querySelectorAll("thead th")
For i = 0 To headers.Length - 1
.Cells(r, i + 1) = headers.item(i).innerText
Next
Dim tableContents As Object
Set tableContents = hTable.querySelectorAll("tbody tr th,td")
For i = 0 To tableContents.Length - 1
If i Mod 4 = 0 Then
c = 1: r = r + 1
Else
c = c + 1
End If
.Cells(r, c) = tableContents.item(i).innerText
Next
End With
End Sub
Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long
With ws
GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row
End With
End Function