用VBA查询历史天气

suzhouxiaozi

下面这段代码是论坛上朋友写的，用来抓取2345网站历史天气用的（http://tianqi.2345.com/wea_history/58357.htm），但是只能查询一个年度内的历史天气，不能跨年度查询，需要怎么修改可以查询几个年度的历史天气呢，比如需要查询2022年到现在的历史天气



Sub 历史天气2023()
   
   
    '创建对象
    Dim xmlHttp As Object, HTML As Object, Table As Object, oRows As Object, oCells As Object, i As Long, num As Long, m As Long, n As Long
    Set xmlHttp = CreateObject("MSXML2.XMLHTTP")
    Set HTML = CreateObject("htmlfile")
    '发送请求
   
    num = 1
   
         Dim QueryYear As Integer
         Dim QueryMonth() As Variant
         Dim arr() As Variant
         Dim cnt As Integer
         For i = 1 To 12
         If Not IsEmpty(Range("N" & i)) Then
             ReDim Preserve arr(cnt)
             arr(cnt) = Range("N" & i).Value
             cnt = cnt + 1
         End If
        Next i
   
    QueryMonth = arr
    QueryYear = 2023 '要查询的年份
         
    For Each qm In QueryMonth
        '指定要查询的城市，修改城市所对应的编码
        'xmlHttp.Open "GET", "http://tianqi.2345.com/wea_history/71237.htm", False
        xmlHttp.Open "GET", "http://tianqi.2345.com/Pc/GetHistory?areaInfo%5BareaId%5D=71237&areaInfo%5BareaType%5D=2&date%5Byear%5D=" & QueryYear & "&date%5Bmonth%5D=" & qm, False
        xmlHttp.send
        '等待响应
        Do While xmlHttp.readyState <> 4
            DoEvents
        Loop
        '得到请求数据
        HTML.body.innerhtml = xmlHttp.responseText
   
        Set Table = HTML.getElementsByTagName("table")(0)

        With Table
            Set oRows = .Rows
            For m = 1 To oRows.Length - 1
                num = num + 1
                Set oCells = oRows(m).Cells
                For n = 0 To oCells.Length - 1
                    Cells(num, n + 1) = Replacestr(Convert(oCells(n).innerText))
                Next
               
            Next
        End With
    Next
   
    Set winhttp = Nothing
    Set HTML = Nothing
    Set Table = Nothing
    Set oRows = Nothing
    Set oCells = Nothing
   
    MsgBox "完成"
End Sub


Function Replacestr(strText As String) As String
    arrreplace = Array("</td>", "</tr>", "</span>", "</table>", "\n", "}", """", Chr(10))
    For Each Item In arrreplace
        Replacestr = Replace(strText, Item, "")
        strText = Replacestr
    Next
End Function

Function Convert(strText As String) As String

    With CreateObject("MSScriptControl.ScriptControl")
   
        .Language = "javascript"
        
        Convert = .Eval("('" & strText & "').replace(/&#\d+;/g,function(b){return String.fromCharCode(b.slice(2,b.length-1))});")
        
        Debug.Print Convert
   
    End With

End Function

约定的童话

for QueryYear = 2022 to 2023

next

suzhouxiaozi

约定的童话 发表于 2024-2-12 11:35
for QueryYear = 2022 to 2023

next

这样子22和23年没问题，但是到2024年3月会报错的吧

lwkz9600

解决了么，求代码，这个代码我也跑不起来  wps  提示For循环未初始