前面我们已经分享过一个天气预报的实例。但是可能代码没有完整，很多网友看了都不是很懂。
今天继续分享一个天气报告的网抓内容。有多种样式可以选择，可以显示全国天气和分省份显示天气，气温和风力；也可以显示地区的的详细信息：包括舒适度，穿衣，旅游等等内容。
作者：小林子-Office中国
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
如喜欢此技巧，手机右上角点开，分享到QQ空间，方便自己以后看
