抓取 天气网站 历史数据！

YZC51

YZC51 发表于 2015-10-20 23:31
请教！出现这些乱码，怎么修改！

已经修改好啦！

1. Sub TQ()
   
2. 
   
3.     Application.ScreenUpdating = 0
   
4.    
   
5.     Set xmlhttp = CreateObject("Microsoft.XMLHTTP")
   
6.     With xmlhttp
   
7.         .Open "get", "http://tianqi.2345.com/t/wea_history/js/59287_201510.js", False
   
8.         .send
   
9.         t = StrConv(.responsebody, vbUnicode)
   
10.         't = .responsetext
    
11.         t1 = Replace(Split(Split(t, "[{ymd:")(1), "},{}]")(0), "ymd:", Chr(10))
    
12.         t1 = Replace(t1, "',", ",")
    
13.         
    
14.         Set reg = CreateObject("vbscript.regexp")
    
15.         reg.Pattern = "[a-z:'W]"
    
16.         reg.Global = True
    
17.         t1 = reg.Replace(t1, "")
    
18.         t1 = Replace(t1, "},{", "")
    
19. 
    
20.         
    
21.     End With
    
22.    
    
23.     Debug.Print Left(t1, 2000) '& Right(t1, 2000)
    
24.    
    
25.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
26.         .SetText t1
    
27.         .PutInClipboard
    
28.     End With
    
29. 
    
30.     With ActiveSheet
    
31.         .[a4].Select
    
32.         .Paste
    
33.         .[a4:a35].TextToColumns Destination:=Range("a4"), Comma:=True
    
34.     End With
    
35.    
    
36.     Set winhttp = Nothing
    
37.     Application.StatusBar = False
    
38.     Application.ScreenUpdating = True
    
39.    
    
40. End Sub

复制代码

YZC51

关纭 发表于 2015-10-21 10:01
我想在http://tianqi.2345.com/wea_history/59287.htm这个网站下载数据。。。并且可以拿到历史月份的数据 ...

请参考11楼的代码！

wlxzwxfx

学习下楼主

zhouhuan29

Sub Tianqi()
Dim str As String

On Error Resume Next

Cells.Delete

t1 = Time

n = 1

For i = 2018 To 2019 '由2011到2019进行循环

For j = 1 To 12 '按1-12月进行循环

If j < 10 Then '给小于10的月份前补数字0（网址需要）

t = 0

Else

t = ""

End If

str = i & t & j

If i = Year(Date) And j > Month(Date) Then Exit For '如果时间大于本月则推出循环，主要是为了不循环今年的后几个月

With ActiveSheet.QueryTables.Add("url;http://www.tianqihoubao.com/lishi/QICHUN/month/" & str & ".html", Range("a" & n)) '天气后报的网址，如果要爬某个城市的天气请把“beijing”改成对应的城市拼音即可

.WebFormatting = xlWebFormattingNone '不包含格式

.WebSelectionType = xlSpecifiedTables '指定table模式

.WebTables = "1" '第1张table

.Refresh False

End With

n = Cells(Rows.Count, 1).End(3).Row + 1

Next

Next

Columns("A:D").Select

ActiveSheet.Range("$A:$D").RemoveDuplicates Columns:=Array(1, 2, 3, 4), Header:=xlNo '删除重复项

Range("C:C,D:D").Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove '插入空行

Columns("B:B").TextToColumns Destination:=Range("B1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True '分列

Columns("D:D").TextToColumns Destination:=Range("D1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True '分类

Columns("F:F").TextToColumns Destination:=Range("F1"), DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=False, Space:=False, Other:=True, OtherChar:="/", FieldInfo:=Array(Array(1, 1), Array(2, 1)), TrailingMinusNumbers:=True '分类

ColumnCells.Replace " ", "", 2 '去掉空格

Cells.Replace "℃", "", 2 '去掉℃

Range("B1:G1") = Array("白天天气", "夜晚天气", "最高气温", "最低气温", "白天风", "夜晚风")

str1 = Time - t1

MsgBox Format(CDate(str1), "hh:mm:ss")
End Sub

YZC51

请参考
Sub Weather()
    Dim strText As String
    Cells.Clear
    n = 2
    For i = 2018 To 2018 '由2019到2019进行循环
        For j = 1 To 12 '按1-12月进行循环
            t = Format(j, "00")
            str1 = i & t
            If i = Year(Date) And j > Month(Date) Then Exit For
            URL = "http://www.tianqihoubao.com/lishi/HAERBIN/month/" & str1 & ".html"
            With CreateObject("MSXML2.XMLHTTP")
                .Open "GET", URL, False
                .setRequestHeader "Connection", "keep-alive"
                .Send
                strText = .responsetext
            End With
            strText = Replace(strText, "风 <", "风 ＜")
            strText = Replace(strText, "href='", "") '取消链接
'            strText = Replace(strText, "href='", "href='http://www.tianqihoubao.com") '完善链接
            strText = "<table" & Split(Split(strText, "风力风向<")(1), "</table>")(0) & "</table>"
            With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
                .SetText strText
                .PutInClipboard
            End With
            Range("a" & n).Select
            ActiveSheet.Paste
            n = Cells(Rows.Count, 1).End(3).Row + 1
        Next
    Next
    Range("A1:D1") = Array("日期", "天气状况", "气温", "风力风向")
End Sub

zhouhuan29

YZC51 发表于 2019-5-13 15:38
请参考
Sub Weather()
    Dim strText As String

显示N=2 变量未定义 错误

YZC51

zhouhuan29 发表于 2019-5-18 11:00
显示N=2 变量未定义 错误

去掉Option Explicit试试！

403933

zhouhuan29 发表于 2019-5-11 17:42
Sub Tianqi()
Dim str As String

请问怎么把天气数据直接写入access数据库

403933

YZC51 发表于 2019-5-13 15:38
请参考
Sub Weather()
    Dim strText As String

请问怎么把天气数据直接写入access数据库

YZC51

403933 发表于 2019-6-14 21:03
请问怎么把天气数据直接写入access数据库

抱歉，不会用数据库