网页抓取分享

VBA万岁 · 发表于 2014-10-20 16:30

onlycxb 发表于 2014-10-20 12:48
总页码我怎么没看到？

其实，用ie法也可解决：
Sub 新浪模拟交易3()
'On Error Resume Next
Cells.ClearContents
Dim p%, tp As Long, i%, j%, t, r As Object

With CreateObject("internetexplorer.application")
.Visible = True
.Navigate "http://jiaoyi.sina.com.cn/jy/stock/ranking/"
Do Until .readyState = 4
      DoEvents
Loop

t = Timer
Do While t + 5 > Timer
      DoEvents
Loop
Cells(1, 12) = Split(Split(.Document.all.tags("BODY")(0).innerText, "12345 共")(1), "页")(0) '此句显示总页数
For p = 1 To 2
      t = Timer
      Do While t + 5 > Timer
         DoEvents
      Loop

      Set r = .Document.all.tags("table")(0).Rows
      For i = 0 To r.Length - 1
         For j = 0 To r(i).Cells.Length - 1
            Cells((p - 1) * 21 + i + 1, j + 1) = r(i).Cells(j).innerText
         Next j
      Next i

      .Document.all.tags("a")(94).Click
Next p
End With
End Sub

VBA万岁 · 发表于 2014-10-20 16:32

本帖最后由 VBA万岁于 2014-10-21 08:32 编辑

VBA万岁发表于 2014-10-20 16:30
其实，用ie法也可解决：
Sub 新浪模拟交易3()
'On Error Resume Next

附件如下：

新浪模拟交易排行榜.zip (577.88 KB, 下载次数: 23)

onlycxb · 发表于 2014-10-20 19:29

VBA万岁发表于 2014-10-20 16:30
其实，用ie法也可解决：
Sub 新浪模拟交易3()
'On Error Resume Next

Cells(1, 12) = Split(Split(.Document.all.tags("BODY")(0).innerText, "12345 共")(1), "页")(0) '此句显示总页数,这里12345就不要取了。

onlycxb · 发表于 2014-10-20 22:26

本帖最后由 onlycxb 于 2014-10-21 08:03 编辑

分享8：

Sub ()
'需求：提取[url]http://www.cffex.com.cn/fzjy/tjsj/pztj/pzrtj/[/url]数据
'特点：xml数据，乱码转换.
Dim objHR As New WinHttp.WinHttpRequest
Dim Url$, St$, xmlDoc, arr
Dim i%, j%, m%, n%
Url = "http://www.cffex.com.cn/fzjy/tjsj/pztj/pzrtj/2014/index.xml"
With objHR
.Open "GET", Url, False
' .SetRequestHeader "Accept", "application/xml, text/xml, */*"
' .SetRequestHeader "Accept-Language", "zh-cn,zh;q=0.8,en-us;q=0.5,en;q=0.3"
.Send
If .Status = 200 Then
St = StrConv(.ResponseBody, vbUnicode) '原代码St = .ResponseText，为转码改现语句
End If
End With
With CreateObject("Microsoft.XMLDOM")
.LoadXML (St)
m = .DocumentElement.ChildNodes.Length
ReDim arr(1 To m, 1 To 7)
'以上可将网页数据保存入数组，根据需求，可加入类型（IF,TF）和日期条件，便可得到要查询的结果
For i = 1 To m
Set xmlDoc = .DocumentElement.ChildNodes(i - 1)
n = xmlDoc.ChildNodes.Length
For j = 1 To n
arr(i, j) = xmlDoc.ChildNodes(j - 1).Text
Next j
Next i
End With
' 数组arr保存入表格代码省略
Sheet1.Cells.Clear
Sheet1.[a2].Resize(UBound(arr, 1), UBound(arr, 2)) = arr
End Sub

复制代码

Sub 品种日统计数据2()
Dim myQuery
With ActiveSheet
.Cells.Delete
Set myQuery = ActiveSheet.QueryTables.Add(Connection:="URL;http://www.cffex.com.cn/fzjy/tjsj/pztj/pzrtj/2014/index.xml", Destination:=.Cells(1, 1))
End With
myQuery.Refresh
End Sub

复制代码

VBA万岁 · 发表于 2014-10-21 10:08

onlycxb 发表于 2014-10-20 22:26
分享8：

测试通过，多谢分享！
需添加引用如下：
添加引用.jpg

VBA万岁 · 发表于 2014-10-21 12:35

onlycxb 发表于 2014-10-15 16:18
继续分享
分享5:提供地址:http://taobao.cjcp.com.cn/cjw11x5/view/11x5qianerzs-2-11ydj-11-3-1000.html
...

测试通过，多谢分享！
补上转码代码如下：

Function BytesToBstr(strBody, CodeBase)       '使用Adodb.Stream对象提取字符串
Dim objStream
On Error Resume Next
Set objStream = CreateObject("Adodb.Stream")
With objStream
      .Type = 1                            '二进制
      .Mode = 3                            '读写
      .Open
      .Write strBody                         '二进制数组写入Adodb.Stream对象内部
      .Position = 0                         '位置起始为0
      .Type = 2                            '字符串
      .Charset = CodeBase                   '数据的编码格式
      BytesToBstr = .ReadText                '得到字符串
End With
objStream.Close
Set objStream = Nothing
If Err.Number <> 0 Then BytesToBstr = ""
On Error GoTo 0
End Function

VBA万岁 · 发表于 2014-10-21 14:55

VBA万岁发表于 2014-10-21 12:35
测试通过，多谢分享！
补上转码代码如下：

Mark如附件：

十一运网抓.zip (1.75 MB, 下载次数: 32)

onlycxb · 发表于 2014-10-21 13:56

本帖最后由 onlycxb 于 2014-10-21 13:58 编辑

分享9

Option Explicit
Sub 招财宝综合排序数据抓取()
'https://zhaocaibao.alipay.com/pf/productList.htm?pfOrderStatus=&pfCurrentPage=210&pfOrderType=&fistView=1
Dim xml As New MSXML2.XMLHTTP, url$, St$, arr, i%, brr, crr, total%, page%, p%
Dim rng As Range
url = "https://zhaocaibao.alipay.com/pf/productList.htm?pfOrderStatus=&pfOrderType=&fistView=1&pfCurrentPage="
sheet1.cells.clear
With xml
.Open "GET", url & "210", False
.send
St = .responseText
total = Split(Split(St, "</span>页")(0), "/")(914) '总数页
End With
'页数较多,近两千页，以取前3页为例
For p = 1 To 3 'total
With xml
.Open "GET", url & page, False
.send
St = .responseText
End With
St = Replace(Replace(St, " ", ""), vbCrLf, "")
St = Replace(St, "<spanclass=""income-ui-tip"">", "")
arr = Split(St, "<liclass=""w154"">")
ReDim brr(1 To UBound(arr) - 2, 1 To 6)
For i = 2 To UBound(arr) - 1
brr(i - 1, 1) = Split(arr(i), "<")(0)
brr(i - 1, 2) = Split(Split(arr(i), "<")(3), ">")(1)
brr(i - 1, 3) = Split(Split(arr(i), "<")(8), ">")(1)
brr(i - 1, 4) = Split(Split(arr(i), "<")(10), ">")(1)
brr(i - 1, 5) = Split(Split(arr(i), "<")(16), ">")(1)
brr(i - 1, 6) = Replace(Split(Split(arr(i), "<")(20), ">")(1), "  ", "")
Next i
Set rng = Sheet1.Cells(Rows.Count, 1).End(xlUp)
rng.Resize(UBound(brr, 1), 6) = brr
Next p
End Sub

复制代码

VBA万岁 · 发表于 2014-10-21 15:16

VBA万岁发表于 2014-10-21 14:55
Mark如附件：

添加引用如下：

VBA万岁 · 发表于 2014-10-21 15:54

本帖最后由 VBA万岁于 2014-10-21 15:56 编辑

onlycxb 发表于 2014-10-21 13:56
分享9

测试通过，多谢分享！
添加引用如59楼，
Mark如附件：

招财宝综合排序数据抓取.zip (364.84 KB, 下载次数: 41)

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

[分享] 网页抓取分享

评分