急，VBA多个网页抓取数据

yangyangzhifeng · 发表于 2016-12-14 15:01

zhczhy2016 发表于 2016-12-14 14:54
这个不会提示内存溢出，这个是是对提取后的结果进行了检查，把重复的项去除，是吗？！

是的你试试看

zhczhy2016 · 发表于 2016-12-15 14:14

yangyangzhifeng 发表于 2016-12-14 15:01
是的你试试看

测试过，效果不错，非常感谢，不过又遇到了新的问题：如何从ASP网页中提取数据。这个网址就是ASP，不知怎么办了？
http://59.49.34.87:2016/Defalut_1.aspx
其中的“补贴情况公示”，打开没有网址，不知怎么办了？

yangyangzhifeng · 发表于 2016-12-15 17:40

zhczhy2016 发表于 2016-12-15 14:14
测试过，效果不错，非常感谢，不过又遇到了新的问题：如何从ASP网页中提取数据。这个网址就是ASP，不知怎 ...

试试看

Dim strText As String, t, i&, j&, TR, TD, n&
Dim reg, n_max&, viewstate$
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "共(\d+)页"
Application.ScreenUpdating = False
Sheet1.Cells.ClearContents
With CreateObject("WinHttp.WinHttpRequest.5.1")
Do
n = n + 1
.Open "POST", "http://59.49.34.87:2016/ApplicationProcess/HuiZTJ_ZJSY.aspx", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
If n = 1 Then
.Send "GridView1%24ctl34%24txtGoPage=1"
Else
.Send "__VIEWSTATE=" & viewstate & "&GridView1%24ctl34%24txtGoPage=" & n
End If
strText = .responsetext
With CreateObject("htmlfile")
.write strText
viewstate = encodeURI(.getElementById("__VIEWSTATE").Value)
t = 0
For Each TR In .all.tags("table")("GridView1").Rows
t = t + 1
If ((t = 1 Or t = 2) And n = 1) Or t > 2 Then
i = i + 1: j = 0
For Each TD In TR.Cells
If n = 1 Then
If reg.test(TD.innertext) Then
n_max = reg.Execute(TD.innertext)(0).submatches(0)
End If
End If
If reg.test(TD.innertext) Then i = i - 1: Exit For
j = j + 1
Sheet1.Cells(i, j) = TD.innertext
Next
End If
Next
End With
If n = n_max Then Exit Do
Loop
End With
Application.ScreenUpdating = True
End Sub
Function encodeURI(strTobecoded As String) As String
With CreateObject("msscriptcontrol.scriptcontrol")
.Language = "JavaScript"
encodeURI = .Eval("encodeURIComponent('" & strTobecoded & "');")
'encodeURIComponent无法转换括号，所以再替换下括号
encodeURI = Replace(Replace(encodeURI, "(", "%28"), ")", "%29")
End With
End Function

复制代码

yangyangzhifeng · 发表于 2016-12-15 18:07

zhczhy2016 发表于 2016-12-15 14:14
测试过，效果不错，非常感谢，不过又遇到了新的问题：如何从ASP网页中提取数据。这个网址就是ASP，不知怎 ...

n_max指定页数不指定全部下载

Sub tet()
Dim strText As String, t, i&, j&, TR, TD, n&
Dim reg, n_max&, viewstate$
n_max = 10
Set reg = CreateObject("vbscript.regexp")
reg.Global = True
reg.Pattern = "共(\d+)页"
Application.ScreenUpdating = False
Sheet1.Cells.ClearContents
Sheet1.Range("A:A").NumberFormatLocal = "@"
With CreateObject("WinHttp.WinHttpRequest.5.1")
Do
n = n + 1
.Open "POST", "http://59.49.34.87:2016/Application/gongs.aspx", False
.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
If n = 1 Then
.Send "GridView1%24ctl53%24txtGoPage=1"
Else
.Send "__VIEWSTATE=" & viewstate & "&GridView1%24ctl53%24txtGoPage=" & n
End If
strText = .responsetext
With CreateObject("htmlfile")
.write strText
viewstate = encodeURI(.getElementById("__VIEWSTATE").Value)
t = 0
For Each TR In .all.tags("table")("GridView1").Rows
t = t + 1
If (t = 1 And n = 1) Or t > 1 Then
i = i + 1: j = 0
For Each TD In TR.Cells
If n = 1 Then
If reg.test(TD.innertext) Then
n_max = IIf(Val(reg.Execute(TD.innertext)(0).submatches(0)) > n_max, n_max, Val(reg.Execute(TD.innertext)(0).submatches(0)))
End If
End If
If reg.test(TD.innertext) Then i = i - 1: Exit For
j = j + 1
Sheet1.Cells(i, j) = TD.innertext
Next
End If
Next
End With
If n = n_max Then Exit Do
Loop
End With
Application.ScreenUpdating = True
End Sub
Function encodeURI(strTobecoded As String) As String
With CreateObject("msscriptcontrol.scriptcontrol")
.Language = "JavaScript"
encodeURI = .Eval("encodeURIComponent('" & strTobecoded & "');")
'encodeURIComponent无法转换括号，所以再替换下括号
encodeURI = Replace(Replace(encodeURI, "(", "%28"), ")", "%29")
End With
End Function

复制代码

zhczhy2016 · 发表于 2016-12-16 08:17

yangyangzhifeng 发表于 2016-12-15 18:07
n_max指定页数不指定全部下载

你真牛，以后有空好好研究一下你的编码，到时还得请教你

zhczhy2016 · 发表于 2016-12-16 16:39

yangyangzhifeng 发表于 2016-12-15 17:40
试试看

这个网页数据，每次打开也会有不同的变动，是不是也需在除重？

zhczhy2016 · 发表于 2017-1-10 08:14

yangyangzhifeng 发表于 2016-12-15 18:07
n_max指定页数不指定全部下载

这个可以分页提取吗？一次性全部提取，时间太长，网站提示“time out‘

Excel__Boy · 发表于 2017-1-12 20:46

Sub test()
Dim ie, dmt, tb, x, y, i
Set ie = CreateObject("InternetExplorer.Application")
With ie
.Visible = True '显示它
.navigate "http://125.70.15.76:2016/pub/gongshi?pageIndex=1" '加载某个页面
Do Until .ReadyState = 4 And .busy = False '等待页面加载完毕
DoEvents
Loop
Set dmt = .document
Debug.Print dmt.body.outerhtml
'Stop
For i = 1 To 10
Set dmt = .document
Set tb = dmt.all.tags("table")(1)
For x = 0 To tb.Rows.Length - 1
For y = 0 To tb.Rows(x).Cells.Length - 1
Cells(x + 1, y + 1) = tb.Rows(x).Cells(y).innertext
Next y
Next x
dmt.getElementById("_MvcPager_Ctrl0_pib").Value = i + 1
dmt.getElementsByTagName("input")(7).Click
Do Until .ReadyState = 4 And .busy = False '等待页面加载完毕
Debug.Print .busy
DoEvents
Loop
'Stop
Worksheets.Add after:=Worksheets(Worksheets.Count)
Next i
End With
End Sub

复制代码

Kaohsing · 发表于 2017-1-18 09:11

http://59.49.34.87:2016/Application/gongs.aspx该网址数据较多，代码运行时间较长。

zhczhy2016 · 发表于 2017-2-7 10:07

Kaohsing 发表于 2017-1-18 09:11
http://59.49.34.87:2016/Application/gongs.aspx该网址数据较多，代码运行时间较长。

非常感谢，

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

急，VBA多个网页抓取数据

最新热点 /1