如何使用 VBA 从网站上抓取选项值

Question

我正在尝试从网站页面获取位置的名称和值。 例如：我想取值 10 并标记“约翰内斯堡或坦博国际机场”并将其分别插入单元格 B3 和 B4，然后将其循环用于所有 optgroup。我收到错误消息“对象不支持此属性或方法。”我确定我的代码有多个问题。任何帮助将不胜感激。 我的代码如下：

Sub test1()

''''''''''''''''''''''''''''This part states the variables and their dimenstions.
    Dim appIE As Object
    Dim ws As Worksheet
    Dim wb As Workbook
    Dim o

'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

i = 2

    Set wb = Application.Workbooks("Test2")
    Set ws = wb.Worksheets("Europcar Branches")
    Set appIE = CreateObject("internetexplorer.application")

'Navigate to Europcar
'Open internet explorer
With appIE
.Navigate "https://www.europcar.co.za"
.Visible = True
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Application.Wait (Now + TimeValue("0:00:03"))
Do While appIE.busy
    DoEvents
    Application.Wait (Now + TimeValue("0:00:05"))
    Loop
Application.Wait (Now + TimeValue("0:00:02"))

''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''


 Set entry = appIE.document.getElementById("PickupBranch_BranchID_id")
For Each o In entry.getElementsByName("optgroup")
Cells(i, 3).Value = o.Value
    For Each p In entry.getElementsByName("optgroup").Options
    Cells(i, 4).Value = p.innerText
   i = i + 1
Exit For
Next
Exit For

Next
'
'.Navigate "https://www.europcar.co.za"
'.Visible = True

Application.Wait (Now + TimeValue("0:00:01"))

Do While appIE.busy
    DoEvents
    Application.Wait (Now + TimeValue("0:00:03"))
    Loop

End With

appIE.quit
    Set appIE = Nothing

End Sub

一段Html如下：

<select name="PickupBranch_BranchID" class="pick-up-select responsive-select" id="PickupBranch_BranchID_id" style="display: none;" data-placeholder="Pickup Location">
<option value=""></option>
<optgroup value="0" label="Airports">
<option value="10">Johannesburg OR Tambo International Airport</option>
<option value="20">Cape Town International Airport</option>
<option value="76">King Shaka International Airport</option>
<option value="48">Lanseria Airport</option>
<option value="89">Bloemfontein Airport</option>
<option value="70">East London Airport</option>
<option value="61">George Airport</option>
<option value="91">Kimberley Airport </option>
<option value="14">Polokwane Airport</option>
<option value="95">Kruger Mpumalanga Int Airport</option>
<option value="138">Malelane Airport</option>
<option value="79">Margate Airport</option>
<option value="44">CSIR Pretoria</option>
<option value="13">Pietermaritzburg Airport</option>
<option value="7">Port Elizabeth Airport</option>
<option value="84">Richards Bay Airport</option>
<option value="75">Umtata Airport</option>
<option value="103">Upington Airport</option>
<option value="52">Wonderboom Airport</option>
<option value="46">Germiston Rand Airport</option>

</optgroup>
<optgroup value="3" label="Gauteng">
<option value="133">Boksburg Easyway</option>
<option value="42">Braamfontein</option>
<option value="134">Bryanston Easyway </option>
<option value="43">Centurion</option>
<option value="135">Constantia Kloof Easyway</option>
<option value="45">Fourways</option>
<option value="154">Johannesburg Parkstation</option>
<option value="125">Kramerville</option>
<option value="121">Meadowdale</option>
<option value="50">Megawatt Park</option>
<option value="155">Menlyn Easyway</option>
<option value="47">Mogale City (Krugersdorp Agency)</option>
<option value="11">Pretoria Hatfield</option>
<option value="53">Randburg</option>
<option value="161">Rosebank Gautrain Station</option>
<option value="158">Sandton Gautrain Station</option>
<option value="55">Sandton Town</option>
<option value="59">Vanderbijlpark</option>
</optgroup>
</select>

Answer 1

下面向您展示了如何为一个下拉菜单执行操作（它收集了所有的optgroups）。它避免使用浏览器并使用更快的 xmlhttp 请求。我使用getElementById 获取父select 元素，然后使用getElementsByClassName 检索子option 标签元素。我从 1 循环以避免空的第一个元素。

---

参考资料（VBE > 工具 > 参考资料）：

1. Microsoft HTML 对象库

---

VBA：

Option Explicit
Public Sub GetOptions()
    Dim html As Object, ws As Worksheet, headers()
    Dim i As Long, r As Long, c As Long, numRows As Long

    Set ws = ThisWorkbook.Worksheets("Sheet1")
    Set html = New HTMLDocument
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://www.europcar.co.za/", False
        .send

        html.body.innerHTML = .responseText

        Dim pickupBranches As Object, pickupBranchResults()

        Set pickupBranches = html.getElementById("PickupBranch_BranchID_id").getElementsByTagName("option")
        headers = Array("Pickup Location", "option value")
        numRows = pickupBranches.Length - 1

        ReDim pickupBranchResults(1 To numRows, 1 To 2)

        For i = 1 To numRows
            pickupBranchResults(i, 1) = pickupBranches.item(i).innerText
            pickupBranchResults(i, 2) = pickupBranches.item(i).Value
        Next

        With ws
            .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
            .Cells(2, 1).Resize(UBound(pickupBranchResults, 1), UBound(pickupBranchResults, 2)) = pickupBranchResults
        End With
    End With
End Sub