我如何循环使用我的"；getElementById"；多个网站的VBA？

我是一个非营利组织的成员，该组织给数百名囚犯写信鼓励。他们经常被意外调动，没有时间通知地址变更。然而，每个人在被监禁时的位置都是最新的，并在州政府网站上公开

我试着写一个VBA，通过我的“联系人”列表，访问每个州政府的囚犯位置网站（基于每个囚犯的ID），然后从网站中提取每个人的位置，将其放在一列（$C）为此，它对应于特定人员姓名和ID的行。这样，我可以自动运行检查，以确认每个人仍在同一位置，然后再执行Excel邮件合并以打印信封标签及其地址

• 每个人的网站都是一样的，只在结尾处根据他们的囚犯ID进行更改（例如）
• 我所需要的只是确认惩教设施——所以我只需要从每个囚犯各自的页面中提取一个项目。我已经能够为一个人成功地提取它，但是在使用正确的循环序列获取下一个循环并将其输出到同一行时遇到了问题

下面是我用来获取正确值的方法（我刚刚用MsgBox CFTitle进行了测试）

下面是一个姓名示例列表的屏幕截图（带有实际的囚犯ID），使用与我的列表相同的列： 这是一种快速的方法

我从一张表（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

选项显式
公共子GetInfo（）
Dim响应为字符串，ids（），facilities（），i为长，ws为工作表，计数器为长
Set ws=ThisWorkbook.Worksheets（“Sheet1”）“这对我的测试数据非常有效，但是当我在300多行的整个列表上运行它时，我发现它只能在不同数量的条目上运行（在10-150之间），或者它会给出“运行时错误'91'——对象变量或未设置块变量。”，有时，它会给出相同的“对象变量或未设置块变量”，而不具体命名91。当我调试时，它会转到“facilities（I-1）=.getElementById（“valLocation”）.innerText”行。我没有看到任何应该限制它使用的东西——有什么想法吗？多谢！如果你给我一个完整的列表，我可以从这里调试。此外，一些网站可能不喜欢短时间内的大量请求。感谢您的想法，@QHarr，我确实想知道这是否是外部原因，因为它可以处理的ID数量之间存在如此大的差异。有时它不会处理5个，但一旦它一次处理150个。一些被解职的人返回“id valLocation”——但它仍然对那些人有效，只是很好地将“输入”输出到C列中。我确实发现了一个错误的id（输入错误），它停止了代码并给出了一个红色警告框（不幸的是，我记不起它说了什么，现在我只能得到运行时错误91）。您有完整的列表吗？它为我运行，但有一个未找到，我为它添加了一些错误处理。更新了上面的代码。我可以使用更长的列表来改进错误处理。顺便问一下，您是否有任何网络/带宽问题？您当前的结果：
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