提取网页数据

缔造者

提取以下网址的数据到工作表中：

http://www.hn481.com/Tubiao/Index.aspx

提取网页数据.rar (6.82 KB, 下载次数: 23)

2014-5-20 17:27 上传

点击文件名下载附件

缔造者

根据A1单元格的日期，提取数据。

ccwan

1. Sub cc()
   
2.     Set oDoc = CreateObject("htmlfile")
   
3.     With CreateObject("WinHttp.WinHttpRequest.5.1")
   
4.             .Open "post", "http://www.hn481.com/Tubiao/Index.aspx", False
   
5.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   
6.             .send "__VIEWSTATE=%2FwEPDwUJMzcwMDgxNjg1ZGSZszi3MP0rjTOzG%2F4tSpvMa%2FrcBg%3D%3D&__EVENTVALIDATION=%2FwEWCQLAkZ2LAwLdwIe2CAL6%2BO2aAQKH1MzlCAKM54rGBgL0pLPHDAKdxYHOAQL6rKiSDwK7q7GGCCLyKqovVi9S%2Brryg%2FsBvdGJDkXD&txtLoginName=&txtLoginPwd=&txtBeginTime=" & Format([a1], "YYYY-MM-DD") & "&DropDownList1=asc&Button1=&txtStartIssue=&txtEndIssue=&txtCtype=-2&checkbox3=checkbox"
   
7.             .WaitForResponse
   
8.             oDoc.body.innerHTML = .responsetext
   
9.             Set r = oDoc.all.tags("table")(0).Rows
   
10.             For i = 3 To r.Length - 1
    
11.                 k = [G65536].End(3).Row
    
12.                 For j = 0 To r(i).Cells.Length - 1
    
13.                     Cells(k + 1, j + 2) = r(i).Cells(j).innerText
    
14.                 Next j
    
15.             Next i
    
16.         Set r = Nothing
    
17.     End With
    
18. End Sub

复制代码

LMY123

网页抓取学习中

缔造者

ccwan 发表于 2014-5-21 15:51

感谢老师出手相助！
运行时出现错误：

缔造者

把 With CreateObject("WinHttp.WinHttpRequest.5.1") 改为：With CreateObject("Msxml2.XMLHTTP") 并去掉 .WaitForResponse 居然可以！

缔造者

1. Sub 日期查询1()
   
2. Dim ar
   
3. Dim j As Byte, i As Byte
   
4.     Dim r
   
5.     Dim k As Integer
   
6.     Dim oDoc As Object
   
7.     [b4:az65536].ClearContents
   
8.     ReDim ar(1 To 79, 1 To 51)
   
9.      Set oDoc = CreateObject("htmlfile")
   
10.     With CreateObject("Msxml2.XMLHTTP")
    
11.             .Open "post", "http://www.hn481.com/Tubiao/Index.aspx", False
    
12.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
13.             .send "__VIEWSTATE=%2FwEPDwUJMzcwMDgxNjg1ZGSZszi3MP0rjTOzG%2F4tSpvMa%2FrcBg%3D%3D&__EVENTVALIDATION=%2FwEWCQLAkZ2LAwLdwIe2CAL6%2BO2aAQKH1MzlCAKM54rGBgL0pLPHDAKdxYHOAQL6rKiSDwK7q7GGCCLyKqovVi9S%2Brryg%2FsBvdGJDkXD&txtLoginName=&txtLoginPwd=&txtBeginTime=" & Format([a1], "YYYY-MM-DD") & "&DropDownList1=asc&Button1=&txtStartIssue=&txtEndIssue=&txtCtype=-2&checkbox3=checkbox"
    
14. '            .WaitForResponse
    
15.             oDoc.body.innerHTML = .responsetext
    
16.             Set r = oDoc.all.tags("table")(0).Rows
    
17.             For i = 3 To r.Length - 1
    
18.         k = k + 1 '[b65536].End(3).Row
    
19.         For j = 0 To r(i).Cells.Length - 1
    
20. '        Cells(k + 1, j + 2) = r(i).Cells(j).innerText
    
21.             ar(k, j + 1) = r(i).Cells(j).innerText
    
22.             Next j
    
23.         Next i
    
24.     [b4].Resize(k, 51) = ar
    
25.     Set r = Nothing
    
26. End With
    
27.     Call incol
    
28. End Sub
    
29. Sub incol()
    
30. Dim arr
    
31. Dim i As Byte, j As Byte
    
32. Dim d As Object
    
33. Set d = CreateObject("scripting.dictionary")
    
34. arr = Range("c4:f81") '奖号
    
35. Range("g4:az81").Interior.ColorIndex = xlNone '号码走势区域颜色为无填充颜色
    
36. For i = 1 To 8
    
37. d(i) = i
    
38. Next i
    
39. For i = 1 To 78
    
40. For j = 1 To 4
    
41. If d.exists(arr(i, j)) Then
    
42. Cells(i + 3, 6 + d(arr(i, j))).Interior.ColorIndex = 10 '合并号码走势区域填充绿色
    
43. Cells(i + 3, j * 8 + 6 + d(arr(i, j))).Interior.ColorIndex = 10 '号码走势区域填充绿色
    
44. End If
    
45. Next j
    
46. Next i
    
47. Set d = Nothing
    
48. End Sub
    

复制代码

新快赢481.rar (18.18 KB, 下载次数: 28)

2014-5-21 18:47 上传

点击文件名下载附件

缔造者

LMY123 发表于 2014-5-21 16:03
网页抓取学习中

谢谢关注！
参数不好掌握。

缔造者

ccwan 发表于 2014-5-21 15:51

老师您好！
又打扰您了，如果按最近期数提取（比如50期、100期、500期），怎样修改代码呢？望您再次赐教！谢谢！！

YZC51

缔造者 发表于 2014-6-9 08:28
老师您好！
又打扰您了，如果按最近期数提取（比如50期、100期、500期），怎样修改代码呢？望您再次赐教 ...

请测试

1. Sub YZC52()
   
2.     hh = Cells(Cells.Rows.Count, 2).End(xlUp).Row
   
3. Range("b5:AZ" & hh) = ""
   
4. '    bb$ = [b1]: ccc$ = [c1]
   
5. 
   
6.     With CreateObject("MSXML2.XMLHTTP")
   
7.         URL = "http://www.hn481.com/Tubiao/Index.aspx?rows=100" 'DropDownList1=desc降序'DropDownList1=asc升序
   
8.         .Open "GET", URL, False
   
9. '        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   
10.         .send ' "__VIEWSTATE=%2FwEPDwUJMzcwMDgxNjg1ZGSZszi3MP0rjTOzG%2F4tSpvMa%2FrcBg%3D%3D&__EVENTVALIDATION=%2FwEWCQLAkZ2LAwLdwIe2CAL6%2BO2aAQKH1MzlCAKM54rGBgL0pLPHDAKdxYHOAQL6rKiSDwK7q7GGCCLyKqovVi9S%2Brryg%2FsBvdGJDkXD&txtLoginName=&txtLoginPwd=&txtBeginTime=&DropDownList1=desc&Button1=&txtStartIssue=&txtEndIssue=&txtCtype=-2&checkbox3=checkbox"
    
11.         stext = .responsetext
    
12.         strtext = "<table>" & Split(Split(stext, "<tbody id=""cpdata"">")(1), "<div id=""wrapper"">")(0) & "</table>"
    
13.         'strtext = Replace(strtext, "font color=white", "font color=red")
    
14. 'Debug.Print Mid(stext, 9000, 3000)
    
15.     End With
    
16.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
17.         .SetText strtext
    
18.         .PutInClipboard
    
19.     End With
    
20.     Range("b5").PasteSpecial
    
21.     Cells.Font.Size = 9
    
22.     Range("b5:az" & hh).Interior.ColorIndex = xlNone
    
23. End Sub
    

复制代码