使用Excel VBA选择下拉值后网页不会更新

内森·沃夫

第一次在这里发布,希望能得到一些好的反馈!

我正在尝试自动化从以下网站检索数据的过程:https : //hazards.atcouncil.org/#/seismic?lat=38.461982&lng=-122.425394&address=

返回的参数基于“参考文档”,“风险类别”和“站点类别”下拉值。使用Excel VBA,我已经能够导航到网页,从下拉列表中选择所需的项目,并读取输出中的参数。但是,当我进行选择时,网页不会更新输出值(参数),因此实际上我只是在读取默认参数。似乎正在等待我说“ GO”或某种“事件”,但是我对面向HTML的VBA的了解还不足以弄清楚该说些什么。在来到这里发表之前,我已经进行了很多搜索,发现其他人也遇到了类似的问题,但是下拉菜单的HTML代码结构似乎与我在本网站上所看到的有所不同在其他地方看到。一世'

我真的希望这是一个简单的修复。在此先感谢您的帮助!

这是我的代码(Excel 2016):

Sub ScrapeData()
Dim objIE As Object
Dim Latitude As Double
Dim Longitude As Double
Dim newHour As Variant
Dim newMinute As Variant
Dim newSecond As Variant
Dim waitTime As Variant
Dim valArray() As String
Dim btnSelect As MSHTML.HTMLSelectElement
Dim btnOption As MSHTML.HTMLOptionElement, ElementCol As MSHTML.IHTMLElementCollection
Dim ElementCol1 As MSHTML.IHTMLElementCollection

'Define the latitude and longitude
Latitude = 38.221565
Longitude = -122.46558

'Create the Internet Explorer object
Set objIE = CreateObject("InternetExplorer.Application")
objIE.Top = 0
objIE.Left = 0
objIE.Visible = True

'This will navigate to the website given the latitude and longitude
objIE.navigate ("https://hazards.atcouncil.org/#/seismic?lat=" & Latitude & "&lng=" & Longitude & "&address=")

'wait here while the browser is busy
Do While objIE.Busy = True Or objIE.readyState <> 4: DoEvents: Loop

'This is a designated wait time to allow it to finish loading because sometimes it's not ready
newHour = Hour(Now())
newMinute = Minute(Now())
newSecond = Second(Now()) + 3
waitTime = TimeSerial(newHour, newMinute, newSecond)
Application.Wait waitTime

'Bring the web page to the front
objIE.Visible = True

'Select Design Code Requirements
'Gather all the elements under tag name "option"

Set ElementCol = objIE.document.getElementById("seismic-selector").getElementsByTagName("option")
'Look at the value of each element in ElementCol
For Each btnSelect In ElementCol
    '******************************************************************************
    'This is where I'm having the issue!
    '******************************************************************************
    'If the value is equal to what I'm looking for, then...
    If btnSelect.innerText = "ASCE7-10" Then
        'I need to select this value, but I also need to trigger the web page here
        'I need to tell it "This is what I want, start retrieving information"
        'Instead, it selects the value from the drop down, but it appears to be waiting
        'for me to tell it to "Go"
        'The .Focus and .FireEvent don't appear to do anything
        btnSelect.Focus
        btnSelect.Selected = True
        btnSelect.FireEvent ("onchange")

        'Wait for the web page to update
        newHour = Hour(Now())
        newMinute = Minute(Now())
        newSecond = Second(Now()) + 3
        waitTime = TimeSerial(newHour, newMinute, newSecond)
        Application.Wait waitTime
    'I also need to select these other items from their drop downs
    ElseIf btnSelect.innerText = "IV" Then
        btnSelect.Selected = True
    ElseIf btnSelect.innerText = "D - Stiff Soil" Then
        btnSelect.Selected = True
    End If
Next btnSelect

Dim divElm3 As MSHTML.HTMLDivElement
Dim ElementCol3 As MSHTML.IHTMLElementCollection

Set ElementCol3 = objIE.document.getElementsByClassName("table-row")
i = 1
        For Each divElm3 In ElementCol3
            'The values have return carriages in them, this splits it up by the return carriage (vbLf)
            valArray() = Split(divElm3.innerText, vbLf)
            For j = 1 To (UBound(valArray()) + 1)
                'This puts the values into the worksheet on the "Test" page
                Worksheets("Test").Cells(i, j).Value = Application.Clean(Trim(valArray(j - 1)))
            Next j
            'i will be equal to the number of data values on the web page
            i = i + 1
            'For some reason this pulls everything twice, so I limit it to 20. If you comment
            'this If statement out, you will see what I mean.
            If i > 20 Then
                GoTo EndSub
            End If
        Next divElm3

EndSub:
End Sub

这是HTML代码的相关部分:

<div id="seismic-selector">
<div class="form-group">
<span class="label">Reference Document</span>
<select>
<option value="asce7-16">ASCE7-16</option>
<option value="asce7-10">ASCE7-10</option>
<option value="asce7-05">ASCE7-05</option>
<option value="asce41-17">ASCE41-17</option>
<option value="asce41-13">ASCE41-13</option>
<option value="nehrp-2015">NEHRP-2015</option>
<option value="nehrp-2009">NEHRP-2009</option>
<option value="ibc-2015">IBC-2015</option>
<option value="ibc-2012">IBC-2012</option>
</select>
</div>
<div class="form-group">
<span class="label">Risk Category</span>
<select>
<option value="I">I</option>
<option value="II">II</option>
<option value="III">III</option>
<option value="IV">IV</option>
</select>
</div>
<div class="form-group">
<span class="label">Site Class</span>
<select>
<option value="A">A - Hard Rock</option>
<option value="B">B - Rock</option>
<option value="C">C - Very Dense Soil and Soft Rock</option>
<option value="D">D - Stiff Soil</option>
<option value="E">E - Soft Clay Soil</option>
<option value="F">F - Site Response Analysis</option>
</select>
</div>
<div class="form-group">
<span class="label">Report Title</span>
<input type="text" value="" placeholder="Enter a title..."></div></div>
QHarr

硒:

这是一个使用selenium basic的版本,因为页面响应自动浏览器选择项目。在本原理示例中,直接使用了URLlatlongURL。它是向您展示基本的方法。如果需要,在循环中将这些值连接起来很容易。

有些奇怪,在写表方面很有趣。

下载硒后,您需要转到VBE > Tools > References并添加对的引用Selenium Type Library支持其他一些浏览器,包括IE和FireFox。

抱歉图片的尺寸-我试图通过添加后缀来缩小它们的尺寸sm在链接端,但是s太小。

Option Explicit
Public Sub GetInfo()
    Dim d As WebDriver
    Set d = New ChromeDriver
    Const url = "https://hazards.atcouncil.org/#/seismic?lat=38.221565&lng=-122.46558&address="
    Application.ScreenUpdating = False
    With d
        .AddArgument "--headless"
        .Start "Chrome"
        .get url

        With .FindElementsByCss("#seismic-selector select")
            .item(1).AsSelect.SelectByText "ASCE7-10"
            .item(2).AsSelect.SelectByText "II"
            .item(3).AsSelect.SelectByText "D - Stiff Soil"
        End With

        Dim tables As WebElements
        Do
            Set tables = .FindElementsByClass("table", timeout:=7000)
        Loop While tables.Count = 0

        Dim table As Object, tr As Object, td As Object, r As Long, c As Long
        Dim ws As Worksheet, headers()
        headers = Array("Name", "Value", "Description")
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        With ws
            For Each table In tables
                If Not table.Text = vbNullString Then
                    r = GetLastRow(ws, 1) + 2
                    .Cells(r, 1).Resize(1, UBound(headers) + 1) = headers

                    For Each tr In table.FindElementsByClass("table-row")
                        r = r + 1: c = 0
                        For Each td In tr.FindElementsByTag("div")
                            c = c + 1
                            .Cells(r, c) = td.Text
                        Next
                    Next
                End If
            Next
        End With
        .Quit
        Application.ScreenUpdating = True
    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

来自网页的示例:

样品


工作表样本输出:

片


Internet Explorer(不太理想):

Option Explicit
Public Sub ScrapeData()
    Dim objIE As Object, Latitude As Double, Longitude As Double, dropDowns As Object

    Latitude = 38.221565: Longitude = -122.46558
    Set objIE = CreateObject("InternetExplorer.Application")
    Application.ScreenUpdating = True

    With objIE
        '        .Top = 0
        '        .Left = 0
        .Visible = True
        .navigate ("https://hazards.atcouncil.org/#/seismic?lat=" & Latitude & "&lng=" & Longitude & "&address=")

        Do While .Busy = True Or .readyState <> 4: DoEvents: Loop
        Set dropDowns = .document.querySelectorAll("#seismic-selector select")

        With dropDowns
            .item(0).Focus
            SendKeys "{down}"
            .item(1).Focus
            SendKeys "{down}"
            .item(2).Focus
            SendKeys "{down 3}"
        End With

        Dim tables As Object, table As Object, tr As Object, td As Object, r As Long, c As Long, ws As Worksheet, headers()
        headers = Array("Name", "Value", "Description")
        Set ws = ThisWorkbook.Worksheets("Sheet1")
        Do
            DoEvents
            Set tables = .document.getElementsByClassName("table")
        Loop While tables.Length = 0
        With ws
            For Each table In tables
                If Not table.innerText = vbNullString Then
                    r = GetLastRow(ws, 1) + 2
                    .Cells(r, 1).Resize(1, UBound(headers) + 1) = headers

                    For Each tr In table.getElementsByClassName("table-row")
                        r = r + 1: c = 0
                        For Each td In tr.getElementsByTagName("div")
                            c = c + 1
                            .Cells(r, c) = td.innerText
                        Next
                    Next
                End If
            Next
        End With
        .Quit
    End With
    Application.ScreenUpdating = True
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

本文收集自互联网,转载请注明来源。

如有侵权,请联系 [email protected] 删除。

编辑于
0

我来说两句

0 条评论
登录 后参与评论

相关文章

网页抓取:如何使用 VBA 从网页上的下拉列表中选择一个值(选项))

无法使用硒VBA从网页的下拉菜单中选择一个值

从DropdownItems中选择值后,DropdownButton值不会更新。如何使用selectedValue更新默认值?

如何使用Excel VBA在网页的下拉框中输入值

无法使用硒VBA从网页的下拉菜单中选择

使用VBA选择网站上的下拉值

从 DropdownItems 中选择值后,使用 FutureBuilder 值的 Flutter DropDownButton 不会更新

使用 Cypress 下拉选择值不会发生

从IE网页上的下拉菜单中选择Excel VBA多选

无法使用带有VBA的Selenium从网页的下拉列表中选择复选框

使用 jquery 选择下拉更新的 json 对象值

使用带有VBA的Excel工作表动态填充网页中的下拉框

使用Excel vba登录到javascript网页

使用Excel VBA从网页下载文件

使用 getElementsByClassName 的 Excel 2016 VBA 网页抓取

使用VBA更新Excel Slicer选择时性能不佳

使用Excel VBA对选择值激活组合框操作

使用Excel VBA在JavaScript Web中选择onchange值

选择值后如何使用角材料更新值?

使用Excel VBA创建下拉列表

使用prevAll()时选择时不会正确更新值

使用索引和匹配 (Excel/VBA) 更新列的值

使用熊猫从Excel读取下拉值

使用Selenium的Excel VBA

选择一个后如何立即使用HTML下拉列表“选择”中的值?

Excel:是否可以在下拉列表中选择多个值?(没有VBA)

从Excel(VBA)的下拉菜单中选择选项时清除值

使用下拉菜单中的值保存Excel工作簿(使用VBA代码)

使用onchange选择下拉值