Excel交流网
  • 设为首页|收藏本站|手机版
  • Excel-教程-技巧-培训视频

  • 网站首页
  • Excel教程
  • 关于我们
  • 新闻动态
  • Excel资源
  • 招贤纳士

Excel教程

Excel操作
Excel函数
Excel图表
Excel VBA
Excel 行业应用

联系方式

Excel中国 联系方式
电  话:400-855-3990
邮  编:528400
Email:support@zstm.com
网  址:www.excel-cn.com

当前位置:网站首页 > Excel教程 > Excel VBA
Excel VBA

Excel VBA 天气预报又一则

前面我们已经分享过一个天气预报的实例。但是可能代码没有完整,很多网友看了都不是很懂。

今天继续分享一个天气报告的网抓内容。有多种样式可以选择,可以显示全国天气和分省份显示天气,气温和风力;也可以显示地区的的详细信息:包括舒适度,穿衣,旅游等等内容。


作者:小林子-Office中国

 

Excel天气预报信息

城市代码:

Excel技巧


洛阳天气:

Excel技巧


河南天气:

Excel技巧

全国天气:

Excel技巧

 


 Excel天气预报详细VBA代码:               

   

        Sub 全国天气()

            On Error Resume Next

            Dim objXML As Object

            Dim txtContent As String

            Dim arrT1() As String

            Dim arrT2() As String

            Dim arrT3(1 To 37, 1 To 4) As String

            Dim i As Integer

            

            Application.ScreenUpdating = False

            Range("A1:D38") = ""

            Range("A1:D1") = Array("城市", "天气", "气温(℃)", "风力")

            

            Set objXML = CreateObject("Microsoft.XMLHTTP")

            With objXML

                .Open "GET", "http://flash.weather.com.cn/wmaps/xml/china.xml", False

                .send

                If objXML.Status = 200 Then

                    txtContent = .responsetext

                    arrT1 = Split(txtContent, "<")

                    

                    For i = 2 To UBound(arrT1) - 1

                        arrT2 = Split(arrT1(i), """")

                        arrT3(i - 1, 1) = arrT2(5)

                        arrT3(i - 1, 2) = arrT2(11)

                        arrT3(i - 1, 3) = arrT2(15) & "  ~  " & arrT2(13)

                        arrT3(i - 1, 4) = arrT2(17)

                    Next i

                    

                    Range("A2:D38") = arrT3

                    

                Else

                

                    MsgBox "下载网页数据失败"

                    

                End If

                

            End With

            

            Set objXML = Nothing

            ThisWorkbook.Save

            Application.ScreenUpdating = True

            

        End Sub

        

        

        

        

        Sub 河南天气()

            On Error Resume Next

            Dim objXML As Object

            Dim txtContent As String

            Dim arrT1() As String

            Dim arrT2() As String

            Dim arrT3(1 To 100, 1 To 4) As String

            Dim i As Integer

            

            Application.ScreenUpdating = False

            Range("A1:D100") = ""

            Range("A1:D1") = Array("城市", "天气", "气温(℃)", "风力")

            

            Set objXML = CreateObject("Microsoft.XMLHTTP")

            With objXML

               

                .Open "GET", "http://flash.weather.com.cn/wmaps/xml/henan.xml", False

                .send

                If objXML.Status = 200 Then

                    txtContent = .responsetext

                    arrT1 = Split(txtContent, "<")

                    

                    For i = 2 To UBound(arrT1) - 1

                        arrT2 = Split(arrT1(i), """")

                        arrT3(i - 1, 1) = arrT2(5)

                        arrT3(i - 1, 2) = arrT2(17)

                        arrT3(i - 1, 3) = arrT2(21) & "  ~  " & arrT2(19)

                        arrT3(i - 1, 4) = arrT2(25)

                    Next i

                    

                    Range("A2:D100") = arrT3

                    

                Else

                

                    MsgBox "下载网页数据失败"

                    

                End If

                

            End With

            

            Set objXML = Nothing

            ThisWorkbook.Save

            Application.ScreenUpdating = True

            

        End Sub

        

        

        

        

        

        '最新可用城市天气数据接口

        'http://wthrcdn.etouch.cn/WeatherApi?citykey=101180901

        

        Sub 洛阳天气1()

        

            On Error Resume Next

            Application.ScreenUpdating = False

        

            Dim i As Integer

            Dim arr1() As String

            Dim arr2() As String

            Dim arr3() As String

            Dim arr4() As String

            Dim arr5() As String

            Dim arr6() As String

            Dim arr7() As String

            Dim objXML As Object

            Dim txtContent As String

                

            Range("A1:H7") = ""

            Range("A2:H2") = Array("日期", "天气", "气温(℃)", "风力", "晨练", "舒适度", "穿衣", "感冒")

            Range("E4:H4") = Array("晾晒", "旅游", "紫外线", "洗车")

            Range("E6:G6") = Array("运动", "约会", "雨伞")

            

            Set objXML = CreateObject("Microsoft.XMLHTTP")

            With objXML

                .Open "GET", "http://wthrcdn.etouch.cn/WeatherApi?citykey=101180901", False

                .send

                If objXML.Status = 200 Then

                    txtContent = .responsetext

                    arr1 = Split(txtContent, "")

                    arr2 = Split(arr1(1), "")

                    arr3 = Split(arr1(1), "")

                    Range("A1") = "洛阳天气:今天是  " & Format(Now(), "YYYY 年 M 月 D 日") & "  " & Format(Now(), "aaaa")

                    

                    For i = 1 To 5

                        arr4 = Split(arr2(i), ">")

        

                        Cells(i + 2, 1) = Format(Now() + i - 1, "M 月 D 日")

                        Cells(i + 2, 2) = Left(arr4(8), Len(arr4(8)) - 6)

                        Cells(i + 2, 3) = Mid(arr4(5), 4, Len(arr4(5)) - 9) & " ~ " & Mid(arr4(3), 4, Len(arr4(3)) - 10)

                        Cells(i + 2, 4) = Left(arr4(10), Len(arr4(10)) - 11) & Left(arr4(12), Len(arr4(12)) - 8)

                    Next i

                    

                    arr6 = Split(txtContent, "")

                    arr7 = Split(txtContent, "")

                    Cells(6, 8) = "↑" & Left(arr6(1), 5)

                    Cells(7, 8) = "↓" & Left(arr7(1), 5)

                    

                    For j = 1 To 11

                    

                        arr5 = Split(arr3(j), "<")

                        Cells(2 * Int((j + 3) / 4) + 1, ((j - 1) Mod 4) + 5) = arr5(0)

                        

                    Next j

                    

                     

                Else

                

                    MsgBox "下载网页数据失败"

                    

                End If

                

            End With

            

            Set objXML = Nothing

            

            ThisWorkbook.Save

            

            Application.ScreenUpdating = True

            

        End Sub

        

        

        

        

        Sub 洛阳天气2()

        

            '该数据接口已停止更新,代码仅共学习参考用

        

            On Error Resume Next

            Application.ScreenUpdating = False

        

            Dim i As Integer

            Dim arr() As String

            Dim arr1(1 To 6) As String

            Dim arr2(1 To 6) As String

            Dim arr3(1 To 6) As String

            Dim objXML As Object

            Dim txtContent As String

                

            Range("A1:L8") = ""

            Range("A2:L2") = Array("日期", "天气", "气温(℃)", "风力", "穿衣", "紫外线", "洗车", "旅游", "舒适", "晨练", "晾晒", "过敏")

            

            Set objXML = CreateObject("Microsoft.XMLHTTP")

            With objXML

                .Open "GET", "http://m.weather.com.cn/data/101180901.html", False   '此数据接口不稳定,且已停止更新

                .send

                If objXML.Status = 200 Then

                    txtContent = .responsetext

                    arr = Split(txtContent, """")

                    

                    Range("A1") = "洛阳天气:今天是  " & arr(13) & "  " & arr(21)

                    

                    arr1(1) = arr(33)

                    arr1(2) = arr(37)

                    arr1(3) = arr(41)

                    arr1(4) = arr(45)

                    arr1(5) = arr(49)

                    arr1(6) = arr(53)

                    

                    arr2(1) = arr(81)

                    arr2(2) = arr(85)

                    arr2(3) = arr(89)

                    arr2(4) = arr(93)

                    arr2(5) = arr(97)

                    arr2(6) = arr(101)

                    

                    arr3(1) = arr(209)

                    arr3(2) = arr(213)

                    arr3(3) = arr(217)

                    arr3(4) = arr(221)

                    arr3(5) = arr(225)

                    arr3(6) = arr(229)

                    

                    Cells(3, 5) = arr(265)

                    Cells(3, 6) = arr(281)

                    Cells(3, 7) = arr(289)

                    Cells(3, 8) = arr(293)

                    Cells(3, 9) = arr(297)

                    Cells(3, 10) = arr(325)

                    Cells(3, 11) = arr(329)

                    Cells(3, 12) = arr(333)

                    

                    For i = 1 To 6

                       

                        Cells(i + 2, 1) = CDate(arr(13)) + i - 1

                        Cells(i + 2, 2) = arr1(i)

                        Cells(i + 2, 3) = arr2(i)

                        Cells(i + 2, 4) = arr3(i)

                    

                    Next i

                    

                Else

                

                    MsgBox "下载网页数据失败"

                    

                End If

                

            End With

            

            Set objXML = Nothing

            

            ThisWorkbook.Save

            

            Application.ScreenUpdating = True

            

        End Sub


      洛阳天气按钮事件(其他的同理):

        Private Sub CommandButton1_Click()

        

        On Error Resume Next

        Call 洛阳天气1


        Dim STR As String

        STR = "洛阳天气,今天是,二零一六年," & Format(Now(), " M 月 D 日") & " ," & Format(Now(), "aaaa") & "。          今天白天" & Range("B3") & "。          气温," & Application.Substitute(Range("C3"), "~", "到") & "摄氏度" & "。          风向," & Range("D3") & "。      " & Range("E3") & "晨练。" & "。     今天天气总体感觉" & Range("F3") & "。      关注天气,安全出行。本次天气预报,由小林子,倾情奉献。"

        CreateObject("SAPI.SpVoice").Speak STR

        

        End Sub

        


点击加入群:Excel部落 结识Excel大神
学好Excel,效率成倍提高,薪水稳步增长,职位快速提升
每天一个源创技巧,如觉得有用,请点上面 关注。更重要手机转发分享




如喜欢此技巧,手机右上角点开,分享到QQ空间,方便自己以后看



点击次数:  更新时间:2016-12-28 16:33:12  【打印此页】  【关闭】
上一条:Excel日期输入选择器  下一条:Excel vba 网抓天气预报
本站动态|在线留言|在线反馈|友情链接|会员中心|站内搜索|网站地图|网站管理

中山市天鸣科技发展有限公司 版权所有 1999-2020 粤ICP备10043721号

广东省中山市西苑广场富贵阁 528400

QQ:4008553990 电话:0760-88315075

Excel交流网主要交流Excel教程、Excel技巧、Excel培训、Excel函数公式、Excel图表以及Excel VBA,为网友提供一个最全的Excel交流网站

Excel教程|Excel技巧|Excel培训|Excel函数公式|Excel图表|VBA

Powered by MetInfo 5.3.12 ©2008-2021  www.metinfo.cn