ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

快捷登录

搜索
EH技术汇-专业的职场技能充电站 妙哉!函数段子手趣味讲函数 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
HR薪酬管理数字化实战 Excel 2019函数公式学习大典 不用妈妈陪默写神器 打造核心竞争力的职场宝典
300集Office 2010微视频教程 数据工作者的案头书 免费直播课集锦 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2016实战技巧学习锦囊 WPS表格从入门到精通 Excel VBA经典代码实践指南
查看: 229|回复: 2

[求助] 用VBA查询历史天气

[复制链接]

TA的精华主题

TA的得分主题

发表于 2024-2-12 09:40 | 显示全部楼层 |阅读模式
本帖最后由 suzhouxiaozi 于 2024-2-12 11:23 编辑

下面这段代码是论坛上朋友写的,用来抓取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

TA的精华主题

TA的得分主题

发表于 2024-2-12 11:35 | 显示全部楼层
for QueryYear = 2022 to 2023

next

TA的精华主题

TA的得分主题

 楼主| 发表于 2024-2-12 12:09 | 显示全部楼层
约定的童话 发表于 2024-2-12 11:35
for QueryYear = 2022 to 2023

next

这样子22和23年没问题,但是到2024年3月会报错的吧
您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

最新热点上一条 /1 下一条

手机版|关于我们|联系我们|ExcelHome

GMT+8, 2024-2-27 17:03 , Processed in 0.043488 second(s), 16 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2023 Wooffice Inc.

   

沪公网安备 31011702000001号 沪ICP备11019229号-2

本论坛言论纯属发表者个人意见,任何违反国家相关法律的言论,本站将协助国家相关部门追究发言者责任!     本站特聘法律顾问:李志群律师

快速回复 返回顶部 返回列表