Как я могу перебрать VBA "getElementById" для нескольких веб-сайтов? - PullRequest
Новая
       19

Как я могу перебрать VBA "getElementById" для нескольких веб-сайтов?

0 голосов
/ 30 июня 2018

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

Я пытаюсь написать VBA, которая просматривает мой «список контактов» и посещает веб-сайт о местонахождении заключенных каждого правительства штата (на основе идентификатора каждого заключенного), а затем извлекает местоположение каждого человека из веб-сайта и помещает его в столбец ($ C ) для этой цели, которая соответствует строке для имени и идентификатора этого конкретного человека. Таким образом, я мог бы автоматически выполнить проверку, чтобы подтвердить, что каждый из них по-прежнему находится в том же месте, прежде чем выполнить почтовое слияние в Excel для печати этикеток на конвертах с их адресами.

  • Веб-сайт одинаков для каждого, и в конце изменяется только по его идентификатору заключенного (например, http://mdocweb.state.mi.us/OTIS2/otis2profile.aspx?mdocNumber=226475)
  • Все, что мне нужно, это подтвердить исправительное учреждение, поэтому мне нужно извлечь только один предмет из соответствующей страницы каждого заключенного. Я смог успешно извлечь его для одного человека, но у меня возникли проблемы с использованием правильной последовательности циклов, чтобы получить следующий и вывести его в той же строке.

Вот то, что я использую, чтобы получить правильное значение (я только что тестировал с CFTitle MsgBox) 

Dim IE As New InternetExplorer
IE.Visible = False
IE.navigate "http://mdocweb.state.mi.us/OTIS2/otis2profile.aspx?mdocNumber=" & Range("PrisonerID").Value
Do
DoEvents
Loop Until IE.readyState = READYSTATE_COMPLETE
Dim Doc As HTMLDocument
Set Doc = IE.document
Dim CFTitle As String
CFTitle = Trim(Doc.getElementById("valLocation").innerText)

А вот снимок экрана с примером списка имен (с фактическими идентификаторами заключенного), используя те же столбцы, что и мой список: Пример контактного листа Excel

1 Ответ

0 голосов
/ 01 июля 2018

Это быстрый способ.

Я прочитал идентификаторы заключенных в массив из листа (колонка K). Если вы читаете с листа, вы получаете 2D-массив, а затем зацикливаете первое измерение, чтобы получить идентификаторы.

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

Я использую .getElementById("valLocation") для получения информации о исправительном учреждении.

Я храню эти результаты в массиве с именем facilities.

В конце я записываю идентификаторы и местоположения на лист, столбец C, с: 

.Cells(2, 3).Resize(UBound(facilities) + 1, 1) = Application.WorksheetFunction.Transpose(facilities)

VBA: 

Option Explicit
Public Sub GetInfo()
    Dim sResponse As String, ids(), facilities(), i As Long, ws As Worksheet, counter As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")   '<==change as appropriate
    ids = ws.Range("K2:K" & GetLastRow(ws)).Value
    ReDim facilities(UBound(ids, 1) - 1)
    Application.ScreenUpdating = False
    On Error GoTo errhand
    With CreateObject("MSXML2.XMLHTTP")
        For i = LBound(ids, 1) To UBound(ids, 1)
            counter = counter + 1
            .Open "GET", "http://mdocweb.state.mi.us/OTIS2/otis2profile.aspx?mdocNumber=" & ids(i, 1), False
            .send
            sResponse = StrConv(.responseBody, vbUnicode)
            sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))

            With CreateObject("htmlFile")
                .Write sResponse
                facilities(i - 1) = .getElementById("valLocation").innerText
            End With
NextId:
        Next i
    End With
    With ws
        .Cells(2, 3).Resize(UBound(facilities) + 1, 1) = Application.WorksheetFunction.Transpose(facilities)
    End With
    Application.ScreenUpdating = True
    Exit Sub

errhand:
    Debug.Print counter
    Debug.Print Err.Number & " " & Err.Description
    Select Case Err.Number
        Case 91
        Err.Clear
        facilities(i - 1) = "Not found"
        GoTo NextId
    End Select
    Application.ScreenUpdating = True
End Sub

Результат на листе:

Result in sheet

...