ExcelHome技术论坛

 找回密码
 免费注册

QQ登录

只需一步,快速开始

EH搜索     
EH云课堂-专业的职场技能充电站 Excel转在线管理系统,怎么做看这里 Excel服务器-会Excel,做管理系统 Excel Home精品图文教程库
Excel不给力? 何不试试FoxTable! Excel 2016函数公式学习大典 高效办公必会的Office实战技巧 免费下载Excel行业应用视频
300集Office 2010微视频教程 Tableau-数据可视化工具 精品推荐-800套精选PPT模板,点击获取 ExcelHome出品 - VBA代码宝免费下载
你的Excel 2010实战技巧学习锦囊 欲罢不能, 过目难忘的 Office 新界面 Excel VBA经典代码实践指南
查看: 1831|回复: 19

[求助] 提取网页数据

[复制链接]

TA的精华主题

TA的得分主题

发表于 2014-5-20 17:28 | 显示全部楼层 |阅读模式
提取以下网址的数据到工作表中:

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

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-5-21 11:41 | 显示全部楼层

TA的精华主题

TA的得分主题

发表于 2014-5-21 15:51 | 显示全部楼层
  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
复制代码

TEST.rar

16.34 KB, 下载次数: 28

评分

参与人数 2鲜花 +4 收起 理由
缔造者 + 2 感谢帮助
LMY123 + 2 感谢帮助

查看全部评分

TA的精华主题

TA的得分主题

发表于 2014-5-21 16:03 | 显示全部楼层

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-5-21 17:14 | 显示全部楼层
ccwan 发表于 2014-5-21 15:51

感谢老师出手相助!
运行时出现错误:
QQ截图20140521171131.gif

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-5-21 18:46 | 显示全部楼层
把 With CreateObject("WinHttp.WinHttpRequest.5.1") 改为:With CreateObject("Msxml2.XMLHTTP") 并去掉 .WaitForResponse 居然可以!

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-5-21 18:47 | 显示全部楼层
  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, 下载次数: 21)

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-5-21 18:54 | 显示全部楼层
LMY123 发表于 2014-5-21 16:03
网页抓取学习中

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

TA的精华主题

TA的得分主题

 楼主| 发表于 2014-6-9 08:28 | 显示全部楼层
ccwan 发表于 2014-5-21 15:51

老师您好!
又打扰您了,如果按最近期数提取(比如50期、100期、500期),怎样修改代码呢?望您再次赐教!谢谢!!

TA的精华主题

TA的得分主题

发表于 2016-7-5 12:38 | 显示全部楼层
缔造者 发表于 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.     With CreateObject("MSXML2.XMLHTTP")
  6.         URL = "http://www.hn481.com/Tubiao/Index.aspx?rows=100" 'DropDownList1=desc降序'DropDownList1=asc升序
  7.         .Open "GET", URL, False
  8. '        .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
  9.         .send ' "__VIEWSTATE=%2FwEPDwUJMzcwMDgxNjg1ZGSZszi3MP0rjTOzG%2F4tSpvMa%2FrcBg%3D%3D&__EVENTVALIDATION=%2FwEWCQLAkZ2LAwLdwIe2CAL6%2BO2aAQKH1MzlCAKM54rGBgL0pLPHDAKdxYHOAQL6rKiSDwK7q7GGCCLyKqovVi9S%2Brryg%2FsBvdGJDkXD&txtLoginName=&txtLoginPwd=&txtBeginTime=&DropDownList1=desc&Button1=&txtStartIssue=&txtEndIssue=&txtCtype=-2&checkbox3=checkbox"
  10.         stext = .responsetext
  11.         strtext = "<table>" & Split(Split(stext, "<tbody id=""cpdata"">")(1), "<div id=""wrapper"">")(0) & "</table>"
  12.         'strtext = Replace(strtext, "font color=white", "font color=red")
  13. 'Debug.Print Mid(stext, 9000, 3000)
  14.     End With
  15.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  16.         .SetText strtext
  17.         .PutInClipboard
  18.     End With
  19.     Range("b5").PasteSpecial
  20.     Cells.Font.Size = 9
  21.     Range("b5:az" & hh).Interior.ColorIndex = xlNone
  22. End Sub
复制代码

评分

参与人数 1鲜花 +2 收起 理由
缔造者 + 2 值得肯定

查看全部评分

您需要登录后才可以回帖 登录 | 免费注册

本版积分规则

关闭

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

关注官方微信,每天学会一个新技能

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

GMT+8, 2019-8-26 00:00 , Processed in 0.105008 second(s), 15 queries , Gzip On, MemCache On.

Powered by Discuz! X3.4

© 1999-2020 Wooffice Inc.

   

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

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

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