vba - 如何循环访问多个网站的 "getElementById"VBA？

Question

我是一个非盈利组织的一员，该组织致信鼓励数百名在狱中的人。他们经常被意外转移，没有时间通知地址更改。但是，每个人在被监禁时的位置 是 在州政府的网站上保持最新并可公开访问。

我正在尝试编写通过我的“联系人”列表并访问每个州政府的囚犯位置网站(基于每个囚犯的 ID)的 VBA，然后从网站中提取每个人的位置，将其放在列($C)中与该特定人员的姓名和 ID 对应的行的用途。这样，我可以在执行 Excel 邮件合并以打印带有地址的信封标签之前自动运行检查以确认每个人仍然在同一位置。

每个人的网站都是一样的，只是在最后改变了他们的囚犯ID(例如，http://mdocweb.state.mi.us/OTIS2/otis2profile.aspx?mdocNumber=226475)

我只需要确认惩教设施——所以我只需要从每个囚犯各自的页面中提取一项即可。我已经能够为一个人成功提取它，但是在使用正确的循环序列来获取下一个并将其输出到同一行时遇到了麻烦。

这是我用来获取正确值的方法(我刚刚使用 MsgBox CFTitle 进行了测试)

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)

这是一个示例名称列表的屏幕截图(带有实际的囚犯 ID)，使用与我的列表相同的列:
Example of Excel Contact Sheet

Answer 1

这是一个快速的方法。

我从工作表(K 列)中将囚犯 ID 读入数组中。如果你从一张纸上读入，你会得到一个二维数组，然后循环第一个维度来获取 id。

我循环该数组，为每个 id 发出无浏览器的 XHR 请求。这是通过 GET 快速检索您的信息的方法。要求。

我用 .getElementById("valLocation")获取惩教设施信息。

我将这些结果存储在一个名为 facilities 的数组中.

最后，我将 ID 和位置写入工作表 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

工作表中的结果: