从天气网站 HTML 解析平均温度

Question

您好，我想使用 VBA 从天气网站中提取数据。我想要做的是从这个 HTML 代码中获取数字 6：

                </tr>
                <tr>
                <td class="indent"><span>Temperatura średnia</span></td>
                <td>
          <span class="wx-data"><span class="wx-value">6</span><span class="wx-unit">&nbsp;&#176; C</span></span>
    </td>
            <td>
      -
    </td>
        <td>&nbsp;</td>
        </tr>
        <tr>
        <td class="indent"><span>Temperatura maksymalna</span></td>
        <td>
  <span class="wx-data"><span class="wx-value">7</span><span class="wx-unit">&nbsp;&#176; C</span></span>
</td>
        <td>
  <span class="wx-data"><span class="wx-value">8</span><span class="wx-unit">&nbsp;&#176; C</span></span>
</td>

我试过这样的代码：

Private Sub CommandButton1_Click()
    Dim IE As Object

    ' Create InternetExplorer Object
    Set IE = CreateObject("InternetExplorer.Application")

    ' You can uncoment Next line To see form results
    IE.Visible = False

    ' URL to get data from
    IE.Navigate "https://www.wunderground.com/history/airport/EPGD/2016/10/24/DailyHistory.html?req_city=Pruszcz%20Gdanski&req_statename=Polska&reqdb.zip=00000&reqdb.magic=86&reqdb.wmo=12140"

    ' Statusbar
    Application.StatusBar = "Loading, Please wait..."

    ' Wait while IE loading...
    Do While IE.Busy
        Application.Wait DateAdd("s", 1, Now)
    Loop

    Application.StatusBar = "Searching for value. Please wait..."

    Dim dd As String
    dd = IE.Document.getElementsByClassName("Temperatura średnia")(0).innerText

    MsgBox dd

    ' Show IE
    IE.Visible = True

    ' Clean up
    Set IE = Nothing

    Application.StatusBar = ""
End Sub

没有任何结果（代码什么都不做）。我将不胜感激。

Answer 1

以下是使用 XHR 和 RegEx 从网页中检索所有表格数据的示例：

Option Explicit

Sub ExtractDataWunderground()

    Dim aResult() As String
    Dim sContent As String
    Dim i As Long
    Dim j As Long

    ' retrieve html content
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://www.wunderground.com/history/airport/EPGD/2016/10/24/DailyHistory.html", False
        .Send
        sContent = .ResponseText
    End With
    ' parse with regex
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        ' minor html simplification
        .Pattern = "<span[^>]*>|</span>|[\r\n\t]*"
        sContent = .Replace(sContent, "")
        ' match each table row
        .Pattern = "<tr><td class=""indent"">(.*?)</td><td>(.*?)</td><td>(.*?)</td><td>(.*?)</td></tr>"
        With .Execute(sContent)
            ReDim aResult(1 To .Count, 1 To 4)
            ' each row
            For i = 1 To .Count
                With .Item(i - 1)
                    ' each cell
                    For j = 1 To 4
                        aResult(i, j) = DecodeHTMLEntities(.SubMatches(j - 1))
                    Next
                End With
            Next
        End With
    End With
    ' output result
    Cells.Delete
    Output Cells(1, 1), aResult
    MsgBox "Completed"

End Sub

Function DecodeHTMLEntities(sText As String) As String

    Static oHtmlfile As Object
    Static oDiv As Object

    If oHtmlfile Is Nothing Then
        Set oHtmlfile = CreateObject("htmlfile")
        oHtmlfile.Open
        Set oDiv = oHtmlfile.createElement("div")
    End If
    oDiv.innerHTML = sText
    DecodeHTMLEntities = oDiv.innerText

End Function

Sub Output(oDstRng As Range, aCells As Variant)
    With oDstRng
        .Parent.Select
        With .Resize( _
            UBound(aCells, 1) - LBound(aCells, 1) + 1, _
            UBound(aCells, 2) - LBound(aCells, 2) + 1 _
        )
            .NumberFormat = "@"
            .Value = aCells
            .Columns.AutoFit
        End With
    End With
End Sub

我的输出如下：

要提取平均温度，您可以从索引为 0 的第一个匹配项中获取值，因为平均温度位于表的第一行：

Sub ExtractMeanTempWunderground()

    Dim sContent As String

    ' retrieve html content
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://www.wunderground.com/history/airport/EPGD/2016/10/24/DailyHistory.html", False
        .Send
        sContent = .ResponseText
    End With
    ' parse with regex
    With CreateObject("VBScript.RegExp")
        .Global = True
        .MultiLine = True
        .IgnoreCase = True
        ' minor html simplification
        .Pattern = "<span[^>]*>|</span>|[\r\n\t]*"
        sContent = .Replace(sContent, "")
        ' match each table row
        .Pattern = "<tr><td class=""indent"">.*?</td><td>(.*?)</td><td>.*?</td><td>.*?</td></tr>"
        With .Execute(sContent)
            If .Count = 15 Then
                ' get the first row value only
                MsgBox DecodeHTMLEntities(.Item(0).SubMatches(0))
            Else
                MsgBox "Data structure inconsistence detected"
            End If
        End With
    End With

End Sub

Function DecodeHTMLEntities(sText As String) As String

    Static oHtmlfile As Object
    Static oDiv As Object

    If oHtmlfile Is Nothing Then
        Set oHtmlfile = CreateObject("htmlfile")
        oHtmlfile.Open
        Set oDiv = oHtmlfile.createElement("div")
    End If
    oDiv.innerHTML = sText
    DecodeHTMLEntities = oDiv.innerText

End Function

注意，这些方法在网页结构改变之前都有效。