网爬数据最优方案！！！

一碧清蓝

以下网爬代码总觉得不够理想，还能怎么优化？网爬数据到底有没有最优方案？呵呵

1. Sub kao()
   
2.     [a2:c2] = Split("统计时间 在线人数 波动值")
   
3.     Dim regx, i%, mh, tt, p, m, PostData
   
4.    
   
5.     Set regx = CreateObject("vbscript.regexp")
   
6.     regx.Pattern = "<td>(.*?)</td>"    '注意中文的括号（全角）
   
7.     regx.Global = True
   
8.    
   
9.     For p = 1 To 7
   
10.    
    
11.         PostData = "PageIndex=" & p & "&__RequestVerificationToken=CfDJ8Oxgi0PF5dtKgteCEWR3ZKKzhWUHnMIkczUHpAA12yTUk-KolOww9ZYTIz6y8-tIfgH2yCgFH-DCVvplmsOa2aRf8VuJtozMmUX_clPPMks-XT6jl3vSufB9_l7nCiRKDdhrvCjTdqPEx7XgPW2-DTk"
    
12.         With CreateObject("msxml2.xmlhttp")
    
13.             .Open "POST", "http://www.77tj.org/tencent/", False
    
14.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
    
15.             .send (PostData)
    
16.             tt = .responsetext
    
17.         End With
    
18.         tt = Split(tt, "<table class=""gridview"">")(1)
    
19.         
    
20.         Set mh = regx.Execute(tt)
    
21.         For i = 0 To mh.Count - 1 Step 3
    
22.             m = m + 1
    
23.             For j = 1 To 3
    
24.                 Cells(m + 2, j) = Replace(mh(i + j - 1).submatches(0), "+", "+")
    
25.             Next
    
26.         Next
    
27.     Next
    
28.    
    
29.     Columns("A:C").Columns.AutoFit
    
30.     MsgBox "job is okey"
    
31. End Sub
    

复制代码

jiangtaowoo

网抓数据建议转python，requests库配合lxml进行XPath解析，或者用正则，方便太多了

一碧清蓝

jiangtaowoo 发表于 2018-6-13 12:26
网抓数据建议转python，requests库配合lxml进行XPath解析，或者用正则，方便太多了

帮忙把代码改出来呗，有些不是很会用

Kaohsing

建议改成多线程

YZC51

老师的程序已经很强啦,是网站响应慢！

一碧清蓝

自己顶一下，哈哈

blackttea1

顶一下，哈哈

onlycxb

来个更麻烦的

1. Sub Main()
   
2.     Dim strText As String, p As Integer
   
3.     Cells.Clear
   
4.     With CreateObject("MSXML2.XMLHTTP")
   
5.         For p = 1 To 7
   
6.             PostData = "PageIndex=" & p & "&__RequestVerificationToken=CfDJ8Oxgi0PF5dtKgteCEWR3ZKKzhWUHnMIkczUHpAA12yTUk-KolOww9ZYTIz6y8-tIfgH2yCgFH-DCVvplmsOa2aRf8VuJtozMmUX_clPPMks-XT6jl3vSufB9_l7nCiRKDdhrvCjTdqPEx7XgPW2-DTk"
   
7.             .Open "POST", "http://www.77tj.org/tencent/", False
   
8.             .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
   
9.             .Send (PostData)
   
10.             strText = .responsetext
    
11. 
    
12.             strText = "<table" & Split(Split(strText, "<table")(1), "</table>")(0) & "</table>"
    
13.             If p = 1 Then
    
14.                 t = "        <tr>"
    
15.                 t = t + vbCrLf + "            <th>统计时间</th>"
    
16.                 t = t + vbCrLf + "            <th>在线人数</th>"
    
17.                 t = t + vbCrLf + "            <th>波动值</th>"
    
18.                 t = t + vbCrLf + "        </tr>"
    
19.             Else
    
20.                 strText = Replace(strText, t, "")
    
21.             End If
    
22.             CopyToClipbox strText
    
23.             Cells(Rows.Count, 1).End(xlUp).Offset(IIf(p = 1, 0, 1), 0).Select
    
24.             ActiveSheet.Paste
    
25.         Next p
    
26.     End With
    
27. 
    
28. End Sub
    
29. Sub CopyToClipbox(strText As String)
    
30. '文本拷贝到剪贴板
    
31.     With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    
32.         .SetText strText
    
33.         .PutInClipboard
    
34.     End With
    
35. End Sub

复制代码

一碧清蓝

onlycxb 发表于 2018-6-24 17:56
来个更麻烦的

牛掰！O(∩_∩)O谢谢哈！我测试下，呵呵

一碧清蓝

onlycxb 发表于 2018-6-24 17:56
来个更麻烦的

我测试的时候显示“无法运行”是怎么问题啊？你测试过了没