设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 网抓学习笔记，通过抓取快递单号读取快递信息，方法：vb ...
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 10684|回复: 10

[分享] 网抓学习笔记，通过抓取快递单号读取快递信息，方法：vba，powerquery等

[复制链接]
发表于 2017-10-20 10:18 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
新手学习vba网抓，吾不得不提起wcymiss老师，其原创的帖子，网址：http://club.excelhome.net/thread-1159783-1-1.html，
里面给了好多网抓套路，但对新手来说，如雾中看花，当越走进，才发现花是多么的美多么的香。。。
大家有什么网抓心得可以一起研究讨论，当然我只是个菜鸟，只能是洗耳恭听的分了。。。
1.工欲善其事必先利其器，网抓要用什么神器呢？  Filddler等：
   客服端和服务端直接通过数据交换，我们怎么知道他们都在做些什么呢？为此需要FBI给他们中间安装监测装置（Fiddler）
  未完待续。。。



Fiddler关系.png

评分

参与人数 1 +3 收起 理由
小新De和尚头 + 3 给大神点赞，大神教教我~~

查看全部评分

excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
 楼主| 发表于 2017-10-21 12:22 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. '快递查询每天有选定查询次数（好像100次，普通查询够用了），所以最好直接用快递公司拼音+快递单查询为好！
  2. Sub 快递查询kd100()
  3. Dim Url As String, Url2 As String, KdNum As String, KdName As String
  4. Dim Arr(1 To 32, 1 To 2), i As Byte '定义够用的数组arr
  5. Dim mh As Object, strText As String
  6. With Sheets("学习抓取数据")
  7.     .Range("c39:e70") = ""
  8.     KdNum = .Range("B39")
  9.     If Len(KdNum) = 0 Then MsgBox "请输入快递单号": Exit Sub
  10. End With
  11. With CreateObject("MSXML2.XMLHTTP")
  12.        'one
  13.        Url = "http://www.kuaidi100.com/autonumber/autoComNum?text=" & KdNum
  14.        .Open "POST", Url, False
  15.        .Send
  16.         KdName = Split(Split(.responsetext, "comCode"":""")(2), """")(0) '取得快递单公司名称（拼音）
  17.         '此网站可以省略好的都能抓取数据出来
  18.        'two
  19.         Url2 = " http://www.kuaidi100.com/query?type=" & KdName & "&postid=" & KdNum
  20.         .Open "GET", Url2, False
  21.         .Send
  22.         strText = .responsetext '取得快递内容
  23.     End With
  24. 'Debug.Print strText
  25.     With CreateObject("vbscript.regexp") '用正则提取数据
  26.         .Global = True
  27.         .Pattern = "ftime"":""(.+?)"",""context"":""(.+?)"",""location"
  28.         Set mh = .Execute(strText)
  29.         If mh.Count = 0 Then MsgBox "该快递单号无法识别": Exit Sub
  30.         For i = 1 To mh.Count
  31.             Arr(i, 1) = mh(i - 1).submatches(0)
  32.             Arr(i, 2) = mh(i - 1).submatches(1)
  33.         Next
  34.     End With
  35.     Sheets("学习抓取数据").Range("d39:e70") = Arr
  36.     Sheets("学习抓取数据").Range("c39") = ch(KdName) 'ch是自定义函数
  37. End Sub
复制代码
回复

使用道具 举报

 楼主| 发表于 2017-10-21 12:23 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
本帖最后由 苏子龙 于 2017-10-21 12:27 编辑
  1. Sub ExcelVba_快递100_一站式快递查询()
  2.     Dim KdNum As String, KdName As String
  3.     KdNum = Range("b39")
  4.      Range("c39:e70").ClearContents
  5.     Set mx = CreateObject("WinHttp.WinHttpRequest.5.1")
  6.     Set ms = CreateObject("MSScriptControl.ScriptControl") '用这个处理提取出来的数据，可是64位office不支持
  7.     ms.Language = "javascript"
  8.     mx.Open "POST", "http://www.kuaidi100.com/autonumber/autoComNum?text=" & KdNum, False
  9.     mx.Send
  10.     KdName = Split(Split(mx.responsetext, "comCode"":""")(2), """")(0)
  11.     Cells(39, 3) = ch(KdName)
  12.     mx.Open "GET", "http://www.kuaidi100.com/query?id=1&type=" & KdName & "&postid=" & KdNum & "&valicode=&temp=" & Rnd(), False
  13.     mx.Send
  14.     ms.AddCode "a=" & mx.responsetext
  15.     For j = 0 To ms.eval("a.data.length") - 1
  16.         Cells(j + 39, 4) = ms.eval("a.data[" & j & "].time")
  17.         Cells(j + 39, 5) = ms.eval("a.data[" & j & "].context")
  18. '        Cells(j + 39, 6) = ms.eval("a.data[" & j & "].ftime")’ftime和time差不多，基本一样
  19.     Next j
  20. End Sub
复制代码

百度来的例子

网抓学习笔记.zip

787.68 KB, 下载次数: 102
回复

使用道具 举报

 楼主| 发表于 2017-10-23 12:41 | 显示全部楼层
本帖最后由 苏子龙 于 2017-10-23 12:48 编辑
  1. Sub Main()
  2.     Dim strText As String, Url As String, KdNum As String
  3.     Dim i%, Mh As Object, Arr(1 To 99, 1 To 2)
  4.     Range("q2:r100").ClearContents: [p2:p3] = "" '前期处理
  5.    
  6.     KdNum = [o2]
  7.     Url = "http://m.kuaidihelp.com/express/queryResult"
  8.     With CreateObject("MSXML2.XMLHTTP") 'CreateObject("WinHttp.WinHttpRequest.5.1")'
  9.         .Open "POST", Url, False 'POST,GET 根据需要更改
  10.         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
  11.         .setRequestHeader "X-Requested-With", "XMLHttpRequest" '这个一定要加
  12. '        .setRequestHeader "Referer", "http://m.kuaidihelp.com/express/queryResult?word=" & KdNum  '这个可以省略
  13.         .Send "brand=&waybill=" & KdNum
  14. '        strText = .responsetext
  15. '        Debug.Print strText '通过立即窗口查看提取出来的数据
  16. '        Debug.Print TestRegUni(strText)
  17. '        [a29] = strText
  18. '        [a43] = TestRegUni(strText)
  19.          strText = TestRegUni(.responsetext) '转译成正常的文本
  20.          strText = Replace(strText, "<br\/>", " ") '把时间和日期中间的<br\/>替换成空格
  21.     End With
  22. '######################对数据进行处理并写入到单元格###########################
  23. With CreateObject("vbscript.regexp") '用正则提取数据
  24.         .Global = True
  25.         .Pattern = "date"":""(.+?)"",""info"":""(.+?)""}"
  26.         Set Mh = .Execute(strText)
  27.         If Mh.Count = 0 Then MsgBox "该快递单号无法识别": Exit Sub
  28.         For i = 1 To Mh.Count
  29.             Arr(i, 1) = Mh(i - 1).submatches(0)
  30.             Arr(i, 2) = Mh(i - 1).submatches(1)
  31.         Next
  32.     End With
  33.    
  34.     [q2].Resize(99, 2) = Arr
  35.     [p2] = Split(Split(strText, """,""brand_key")(0), "name"":""")(1)
  36.     [p3] = Split(Split(strText, """,""data")(0), "msg"":""")(1)
  37.     Range("Q2:Q100").NumberFormat = "yyyy-mm-dd hh:mm"
  38. End Sub

  40. Function TestRegUni(str As String) As String '用正则提取后处理转译,把response的内容转成常规内容
  41.     Dim strTemp$, i%, y%, Arr(1 To 10000, 1 To 2), 定义足够的的数组
  42.     Dim iReg As Object, iMch As Object, Mch As Object
  43.     Dim d As Object
  44.     strTemp = str
  45.     Set d = CreateObject("scripting.dictionary") '字典去重复内容，可能提高运行速度！
  46.     Set iReg = CreateObject("vbscript.regexp") '提取转译内容
  47.     iReg.Global = True
  48.     iReg.Pattern = "\\u\w{4}"
  49.     Set iMch = iReg.Execute(str)
  50.     For Each Mch In iMch
  51.         If Not d.exists(Mch) Then
  52.             d(Mch) = ""
  53.             y = y + 1
  54.             Arr(y, 1) = ChrW(CLng(Replace(Mch.Value, "\u", "&h")))
  55.             Arr(y, 2) = Mch.Value
  56.         End If
  57.     Next
  58.     For i = 1 To d.Count
  59.         strTemp = Replace(strTemp, Arr(i, 2), Arr(i, 1))
  60.     Next
  61.     TestRegUni = strTemp
  62.     Set iReg = Nothing
  63.     Set d = Nothing
  64. End Function
复制代码

继续学习中。。。

网抓学习笔记.zip

895.11 KB, 下载次数: 52

20171023增
回复

使用道具 举报

yonhe
发表于 2017-10-24 10:04 | 显示全部楼层
谢谢分享,学习学习!
回复

使用道具 举报

 楼主| 发表于 2017-10-24 13:48 | 显示全部楼层
本帖最后由 苏子龙 于 2017-10-24 14:07 编辑
  1. Sub testJS()
  2.     Dim i%, Ms As Object
  3.     Set Ms = CreateObject("MSScriptControl.ScriptControl")
  4.     Ms.Language = "javascript"

  6.     With CreateObject("MSXML2.XMLHTTP")
  7.         .Open "POST", "http://m.kuaidihelp.com/express/queryResult", False
  8.         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded; charset=UTF-8"
  9.         .setRequestHeader "X-Requested-With", "XMLHttpRequest"
  10.         .Send "brand=&waybill=" & [a5] '是快递单号码
  11.         Ms.AddCode "ep=" & .responsetext 'js处理，处理后自动能转码
  12. '        Debug.Print .responsetext
  13.     End With
  14.    
  15.     [b5:e100] = ""
  16.     [b5] = Ms.eval("ep.data.brand_name") '快递公司
  17.     [c5] = Ms.eval("ep.msg") '快递状态
  18.     For i = 0 To Ms.eval("ep.data.list.length") - 1
  19.         Cells(i + 5, 4) = Replace(Ms.eval("ep.data.list[" & i & "].date"), "<br/>", " ") '日期时间
  20.         Cells(i + 5, 5) = Ms.eval("ep.data.list[" & i & "].info") '内容
  21.     Next i
  22. End Sub
复制代码

网抓学习之数据处理.zip

19.45 KB, 下载次数: 41
回复

使用道具 举报

 楼主| 发表于 2017-10-25 14:15 | 显示全部楼层
  1. Rem 参考网址：http://club.excelhome.net/thread-1159783-4-1.html
  2. Sub 按钮1_单击()
  3.     Dim url, html
  4.     url = "http://data.bank.hexun.com/lccp/Jrxp.aspx?"
  5.     url = url & "col=1" '1是今日在售产品
  6.     url = url & "&tag=desc"
  7.     url = url & "&date=" & Format(Date, "yyyy-mm-dd") '查询今日日期，格式：2014-10-21
  8.     url = url & "&page=1" '查询页码

  10.     Set html = CreateObject("htmlfile")
  11.     Debug.Print url
  12.     With CreateObject("msxml2.xmlhttp")
  13.         .Open "GET", url, False
  14.         .send
  15. '        Debug.Print .responsetext
  16.         html.body.innerhtml = .responsetext
  17.         Set tb = html.all.tags("table")(2).Rows
  18.         For i = 0 To tb.Length - 1
  19.             For j = 1 To tb(i).Cells.Length - 1
  20.                 Cells(i + 1, j) = tb(i).Cells(j).innertext
  21.             Next
  22.         Next
  23.     End With
  24. End Sub

  26. Sub 抓取全部页数()
  27.     Dim url, html, PagesNum%, pg%, i%, j%, rw%
  28.     Dim Arr(), iCol%, t#
  29.     t = Timer
  30.     Range("a:i").Clear
  31.     url = "http://data.bank.hexun.com/lccp/Jrxp.aspx?"
  32.     url = url & "col=1" '1是今日在售产品
  33.     url = url & "&tag=desc"
  34.     url = url & "&date=" & Format(Date, "yyyy-mm-dd") '查询今日日期，格式：2014-10-21
  35.     url = url & "&page=" '查询页码
  36.     Set html = CreateObject("htmlfile")
  37.     With CreateObject("msxml2.xmlhttp")
  38.         .Open "GET", url & 1, False '第一次抓取多少页，表有多少列
  39.         .send
  40.         PagesNum = Split(Split(Split(.responsetext, ");</script>")(0), "&date=")(1), ",")(1) '共有多少页
  41.         html.body.innerhtml = .responsetext
  42.         iCol = html.all.tags("table")(2).Rows(1).Cells.Length - 1 '表有多少列
  43.         ReDim Arr(1 To 10000, 1 To iCol) '重新定义足够大的数值
  44.         For pg = 1 To PagesNum '用循环抓取所有页，第一页到最后一页
  45.             DoEvents
  46.             .Open "GET", url & pg, False '第二次抓取所有数据
  47.             .send
  48.             
  49.             html.body.innerhtml = .responsetext
  50.             Set tb = html.all.tags("table")(2).Rows
  51.             For i = IIf(rw > 0, 1, 0) To tb.Length - 1
  52.                 rw = rw + 1
  53.                 For j = 1 To tb(i).Cells.Length - 1
  54.                     Arr(rw, j) = tb(i).Cells(j).innertext
  55.                 Next
  56.             Next
  57.         Next
  58.     End With
  59.     With Range("a1").Resize(rw, iCol)
  60.         .Value = Arr '数据写入单元格
  61.         .Borders.LineStyle = xlContinuous 'xlNone
  62.     End With
  63.     MsgBox Format(Timer - t, "0.000")
  64. End Sub
复制代码

数据处理值html
回复

使用道具 举报

发表于 2017-10-26 08:03 | 显示全部楼层
又是看起来头疼的VBA
回复

使用道具 举报

 楼主| 发表于 2017-10-26 11:49 | 显示全部楼层
  1. Sub Main_Clipbox()
  2.     Dim strText As String
  3.     Application.ScreenUpdating = False
  4.     With CreateObject("MSXML2.XMLHTTP")
  5.         .Open "GET", "http://data.bank.hexun.com/lccp/jrxp.aspx", False
  6.         .Send
  7.         strText = .responsetext
  8.     End With
  9.     strText = "<table" & Split(Split(strText, "<table")(3), "</table>")(0) & "</table>"
  10.     Debug.Print strText
  11.     CopyToClipbox strText
  12.     Range("a:i").Clear
  13.     Call picdel
  14.     Range("a1").Select
  15.     ActiveSheet.Paste
  16.      ActiveSheet.Hyperlinks.Delete '删除超链接
  17.      Application.ScreenUpdating = True
  18. End Sub

  20. Sub CopyToClipbox(strText As String)    '文本拷贝到剪贴板
  21.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
  22.         .SetText strText
  23.         .PutInClipboard
  24.     End With
  25. End Sub
复制代码

网抓学习之数据处理.zip

149.72 KB, 下载次数: 47

20171026

评分

参与人数 1 +22 金币 +18 收起 理由
大灰狼1976 + 22 + 18 不懂就点赞，赞一个

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2017-10-26 11:52 | 显示全部楼层
zhaoyunhai 发表于 2017-10-26 08:03
又是看起来头疼的VBA

一起学，我也不太懂；跟着帖子一步一步走起，不会就多查查资料，再不会就再等等再悟悟吧！
回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-4-26 22:46 , Processed in 0.430822 second(s), 8 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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