如何用VBA提取HTML滑动面板切换的三日气象预报表格数据

已能通过VBA提取HTML中的表格数据，但需要获取今日、明日、后天的预报数据。这些表格会随页面上方滑动面板切换而变化，切换时HTML中对应元素有明确关联：

• <g transform="translate(120,0)"> 对应今日预报
• <g transform="translate(180,0)"> 对应明日预报
• <g transform="translate(240,0)"> 对应后天预报
  表格ID保持不变，但无法修改代码实现日期切换并提取对应数据，原VBA代码如下：

Dim HTMLDoc As New HTMLDocument
    Dim objTable As Object
    Dim lRow As Long
    Dim lngTable As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim ActRw As Long
    Dim objIE As InternetExplorer
    Set objIE = New InternetExplorer
    objIE.navigate "https://fireweather.niwa.co.nz/region/Otago"
    objIE.Visible = True

    Do Until objIE.readyState = 4 And Not objIE.Busy
        DoEvents
    Loop
    Application.Wait (Now + TimeValue("0:00:06")) 'wait for java script to load
    HTMLDoc.body.innerHTML = objIE.document.body.innerHTML
    With HTMLDoc.body
        Set objTable = .getElementsByTagName("table")
        For lngTable = 0 To objTable.Length - 1
            For lngRow = 0 To objTable(lngTable).Rows.Length - 1
                For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
                    ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
                Next lngCol
            Next lngRow
            ActRw = ActRw + objTable(lngTable).Rows.Length + 1
        Next lngTable
    End With
    Set objIE = New InternetExplorer
    objIE.navigate "https://fireweather.niwa.co.nz/region/Southland"

    Do Until objIE.readyState = 4 And Not objIE.Busy
        DoEvents
    Loop
    Application.Wait (Now + TimeValue("0:00:03")) 'wait for java script to load
    HTMLDoc.body.innerHTML = objIE.document.body.innerHTML
    With HTMLDoc.body
        Set objTable = .getElementsByTagName("table")
        For lngTable = 0 To objTable.Length - 1
            For lngRow = 0 To objTable(lngTable).Rows.Length - 1
                For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
                    ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
                Next lngCol
            Next lngRow
            ActRw = ActRw + objTable(lngTable).Rows.Length + 1
        Next lngTable
    End With
    objIE.Quit

修改思路 #

• 复用单个IE实例，避免重复打开浏览器浪费资源
• 通过模拟点击对应<g>元素切换日期面板
• 每次切换后重新抓取当前日期的表格数据，添加标识区分不同时段数据
• 用循环批量处理多地区、多日期，简化代码结构

修改后的VBA代码 #

Sub FetchWeatherForecasts()
    Dim HTMLDoc As New HTMLDocument
    Dim objTable As Object
    Dim lngRow As Long, lngCol As Long, ActRw As Long
    Dim objIE As InternetExplorer
    Dim dateTransforms As Variant, dateLabels As Variant
    Dim regions As Variant
    Dim i As Integer, j As Integer
    Dim gElements As Object, targetG As Object
    
    ' 定义日期对应的transform属性和显示标签
    dateTransforms = Array("translate(120,0)", "translate(180,0)", "translate(240,0)")
    dateLabels = Array("今日预报", "明日预报", "后天预报")
    ' 定义需要抓取的地区
    regions = Array("Otago", "Southland")
    
    Set objIE = New InternetExplorer
    objIE.Visible = True
    ActRw = 1 ' 初始化数据写入起始行号
    
    ' 循环处理每个地区
    For i = LBound(regions) To UBound(regions)
        objIE.navigate "https://fireweather.niwa.co.nz/region/" & regions(i)
        
        ' 等待页面完全加载
        Do Until objIE.readyState = 4 And Not objIE.Busy
            DoEvents
        Loop
        Application.Wait Now + TimeValue("0:00:06") ' 等待JS渲染完成
        
        ' 循环处理每个日期
        For j = LBound(dateTransforms) To UBound(dateTransforms)
            ' 定位对应日期的切换元素
            Set gElements = objIE.document.getElementsByTagName("g")
            Set targetG = Nothing
            For Each elem In gElements
                If elem.getAttribute("transform") = dateTransforms(j) Then
                    Set targetG = elem
                    Exit For
                End If
            Next elem
            
            ' 模拟点击切换日期
            If Not targetG Is Nothing Then
                objIE.document.parentWindow.execScript("arguments[0].click();", "javascript", targetG)
                Application.Wait Now + TimeValue("0:00:02") ' 等待页面更新
            End If
            
            ' 写入地区+日期标识，方便区分数据
            ThisWorkbook.Sheets("Sheet1").Cells(ActRw, 1) = regions(i) & "-" & dateLabels(j)
            ActRw = ActRw + 1
            
            ' 提取当前日期的表格数据
            HTMLDoc.body.innerHTML = objIE.document.body.innerHTML
            Set objTable = HTMLDoc.body.getElementsByTagName("table")
            
            For Each tbl In objTable
                For lngRow = 0 To tbl.Rows.Length - 1
                    For lngCol = 0 To tbl.Rows(lngRow).Cells.Length - 1
                        ThisWorkbook.Sheets("Sheet1").Cells(ActRw + lngRow, lngCol + 1) = tbl.Rows(lngRow).Cells(lngCol).innerText
                    Next lngCol
                Next lngRow
                ActRw = ActRw + tbl.Rows.Length + 1 ' 表格间空一行分隔
            Next tbl
        Next j
    Next i
    
    objIE.Quit
    Set objIE = Nothing
    MsgBox "数据抓取完成！"
End Sub

关键说明 #

1. 日期切换逻辑：遍历页面所有<g>元素，匹配transform属性找到目标切换按钮，通过JS模拟点击触发日期切换。
2. 资源复用：仅打开一次IE实例，依次访问不同地区，减少系统资源消耗。
3. 数据标识：在每组表格前添加地区-日期标签，避免不同时段数据混淆。
4. 等待机制：每次切换后添加短时间等待，确保页面JS完成数据更新，避免抓取到旧数据。

内容的提问来源于stack exchange，提问作者Pmac