网页抓取分享

onlycxb · 发表于 2014-10-14 07:43

分享网抓代码啦！
1.通过百度地图抓取北京地铁1号线附件相关信息

复制代码

onlycxb · 发表于 2014-10-14 07:51

本帖最后由 onlycxb 于 2014-10-14 08:04 编辑

地铁一号线0.PNG

onlycxb · 发表于 2014-10-14 07:57

本帖最后由 onlycxb 于 2014-10-14 08:13 编辑

分享2：抓取北京地铁1号线站名及换乘区间

Option Explicit
'************************************************************
'作　　者：　DongYu QQ:470208739
'************************************************************
Sub 北京地铁1号线_站名及换乘区间()
Dim url, js, p, slen, i, n, str As String, obj As Object
Set js = CreateObject("scriptcontrol")
[a2:d200].ClearContents
js.Language = "jscript"
url = "http://map.baidu.com/?newmap=1&reqflag=pcmap&biz=1&from=webmap&qt=bsl&bsltp=0&uid=bce557d6f7fadd4ea5da39b7&c=131&tn=B_NORMAL_MAP&nn=0&ie=utf-8&l=12&t=" & Rnd() & "" '1号线
With CreateObject("msxml2.xmlhttp")
.Open "get", url, False
.send
js.AddCode ("dy= " & .responsetext)
Cells(1, 1) = "所属公司：": Cells(1, 2) = js.Eval("dy.content[0].company")
Cells(2, 1) = "运行区间：": Cells(2, 2) = js.Eval("dy.content[0].name")
Cells(3, 1) = "运行时间：": Cells(3, 2) = js.Eval("dy.content[0].timetable")
Cells(5, 1) = "序号": Cells(5, 2) = "站名":: Cells(5, 3) = "换乘"
slen = js.Eval("dy.content[0].stations.length") - 1
n = 5
For i = 0 To slen
n = n + 1
Cells(n, 1) = n - 5
Cells(n, 2) = js.Eval("dy.content[0].stations[" & i & "].name")
On Error Resume Next
Set obj = js.Eval("dy.content[0].stations[" & i & "].transfer")
If Not obj Is Nothing Then Cells(n, 3) = js.Eval("dy.content[0].stations[" & i & "].transfer[0][0].name")
Next
End With
End Sub

复制代码

少如 · 发表于 2014-10-14 07:58

没有附件 ?

onlycxb · 发表于 2014-10-14 08:06

少如发表于 2014-10-14 07:58
没有附件 ?

复制代码到excel VBE编辑器运行即可

onlycxb · 发表于 2014-10-14 08:25

分享3：抓取球队数据

Sub 按钮1_单击()
Dim url, html, js
url = "http://nba.win007.com/jsData/matchResult/13-14/l1_1_2013_11.js?version=2014100422"
Set html = CreateObject("htmlfile")
Set js = CreateObject("scriptcontrol")
js.Language = "jscript"
With CreateObject("msxml2.xmlhttp")
.Open "get", url, False
.send
s = .responsetext
Debug.Print s
js.addcode (s)
slen = js.eval("arrData.length") - 1
sslen = js.eval("arrData[0].length") - 1
l = js.eval("arrTeam.length") - 1
js.eval ("球队数据=[]")
For i = 0 To l
s1 = js.eval("arrTeam[" & i & "][0]")
s2 = js.eval("arrTeam[" & i & "][1]")
js.eval ("球队数据[" & s1 & "]=""" & s2 & """")
Next
For i = 0 To slen
For j = 0 To sslen
If j = 4 Or j = 3 Then
ss = js.eval("arrData[" & i & "][" & j & "]")
Cells(i + 2, j + 1) = js.eval("球队数据[" & ss & "]")
Else
Cells(i + 2, j + 1) = js.eval("arrData[" & i & "][" & j & "]")
End If
Next
Next
End With
End Sub

复制代码

czh7971 · 发表于 2014-10-14 09:02

大神啊，能否指示下怎么获得这些链接呢？

suwenkai · 发表于 2014-10-14 09:07

楼主的代码有点像我写的，特别是1楼第15行上的注解。

onlycxb · 发表于 2014-10-14 10:11

suwenkai 发表于 2014-10-14 09:07
楼主的代码有点像我写的，特别是1楼第15行上的注解。

没错。学习的就是你的代码。你查的是武汉公园

onlycxb · 发表于 2014-10-14 10:16

本帖最后由 onlycxb 于 2014-10-14 18:59 编辑

分享4：论坛问题http://club.excelhome.net/thread-1158114-1-1.html
抓取东方财富网数据

'Option Explicit
'************************************************************
'作　　者：　DongYu QQ:470208739 2014/10/14
'************************************************************
Sub 沪深A股()
'需求：抓取http://data.eastmoney.com/cmjzd/，抓取沪深A股
Dim xml As New MSXML2.XMLHTTP, strTxt As String, Url As String, js, Slen As Integer
Dim i As Integer, arr, j
Cells.ClearContents
Url = "http://datainterface.eastmoney.com/EM_DataCenter/JS.aspx?type=GG&sty=GDRS&st=2&sr=true&p=1&ps=50&js=var%20ZWsofIjH={pages:(pc),data:[(x)]}&mkt=1&fd=2014-9-30&rt=47108232"
With xml
.Open "GET", Url, False
.send
strTxt = Split(.responseText, "var ZWsofIjH=")(1)
End With
Set js = CreateObject("scriptcontrol")
js.Language = "jscript"
js.AddCode ("dy= " & strTxt)
Slen = js.eval("dy.data.length") - 1
ReDim arr(1 To Slen + 1, 1 To 14)
For i = 0 To Slen
For j = 1 To 12
arr(i + 1, j) = Split(js.eval("dy.data[" & i & "]"), ",")(j - 1)
Next j
Next i
With Sheet1
.[b2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
For i = 2 To UBound(arr, 1) + 1
.Cells(i, 1) = i - 1
.Cells(i, 2).NumberFormatLocal = "000000"
If Abs(.Cells(i, 5)) > 1 Then .Cells(i, 5) = "-" Else .Cells(i, 5).NumberFormatLocal = "0.00%"
.Cells(i, 6) = Round(.Cells(i, 6))
'其他省略..
Next i
End With
End Sub

复制代码

为方便阅读代码，附数据结构图
JS数据结构如图.PNG

		自动登录	找回密码
密码			免费注册

[分享] 网页抓取分享