Excel VBA Macro Scraping

Question

我想使用 VBA 宏将网页 （https://weather.gc.ca/warnings/index_e.html） 复制到 excel 电子表格中 - 我要复制的只是一个以位置、警告、监视、语句开头的表格的部分

每次我写东西时，它都会复制它

前几行给了我这个：

第一个问题是当它说风警告时......我正在寻找它来复制它，因为它不在网站上，它只是说"风"降雨"特殊天气"等......不是全部

我使用的脚本如下：

Option Explicit
Sub Web_Table_Option_One()
    Dim xml    As Object
    Dim html   As Object
    Dim objTable As Object
    Dim result As String
    Dim lRow As Long
    Dim lngTable As Long
    Dim lngRow As Long
    Dim lngCol As Long
    Dim ActRw As Long
    Set xml = CreateObject("MSXML2.XMLHTTP.6.0")
     ThisWorkbook.Sheets("Sheet2").Cells.ClearContents
    With xml
        .Open "GET", "https://weather.gc.ca/warnings/index_e.html", False
        .send
    End With
    result = xml.responseText
    Set html = CreateObject("htmlfile")
    html.body.innerHTML = result
    Set objTable = html.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("Sheet2").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 Sub

Answer 1

这似乎对我有用，但是，如评论中所述，请考虑使用 API。

此方法查找表，将其复制到剪贴板，然后一次性粘贴整个表。

Option Explicit
Sub Web_Table_Option_One()
    Dim html        As Object: Set html = CreateObject("htmlfile")
    Dim result      As String
    Dim Clip        As Object: Set Clip = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    With CreateObject("MSXML2.XMLHTTP.6.0")
        .Open "GET", "https://weather.gc.ca/warnings/index_e.html", False
        .send
        result = .responseText
    End With
    If Len(result) > 0 Then html.body.innerhtml = result
    Clip.SetText html.getElementsByTagName("table")(0).outerhtml
    Clip.PutInClipboard
    With ThisWorkbook.Sheets("Sheet2")
        .Cells.ClearContents
        .Range("A1").Select
        .PasteSpecial Format:="Unicode Text"
    End With
End Sub