网爬数据最优方案！！！

onlycxb · 发表于 2018-6-25 08:11

一碧清蓝发表于 2018-6-24 23:56
我测试的时候显示“无法运行”是怎么问题啊？你测试过了没

Option Explicit
rem 补齐了变量声明
Sub Main()
Dim strText As String, p As Integer, PostData, t
Cells.Clear
With CreateObject("MSXML2.XMLHTTP")
      For p = 1 To 7
         PostData = "PageIndex=" & p & "&__RequestVerificationToken=CfDJ8Oxgi0PF5dtKgteCEWR3ZKKzhWUHnMIkczUHpAA12yTUk-KolOww9ZYTIz6y8-tIfgH2yCgFH-DCVvplmsOa2aRf8VuJtozMmUX_clPPMks-XT6jl3vSufB9_l7nCiRKDdhrvCjTdqPEx7XgPW2-DTk"
         .Open "POST", "http://www.77tj.org/tencent/", False
         .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
         .Send (PostData)
         strText = .responsetext

         strText = "<table" & Split(Split(strText, "<table")(1), "</table>")(0) & "</table>"
         If p = 1 Then
            t = "       <tr>"
            t = t + vbCrLf + "          <th>统计时间</th>"
            t = t + vbCrLf + "          <th>在线人数</th>"
            t = t + vbCrLf + "          <th>波动值</th>"
            t = t + vbCrLf + "       </tr>"
         Else
            strText = Replace(strText, t, "")
         End If
         CopyToClipbox strText
         Cells(Rows.Count, 1).End(xlUp).Offset(IIf(p = 1, 0, 1), 0).Select
         ActiveSheet.Paste
      Next p
End With

End Sub
Sub CopyToClipbox(strText As String)
'文本拷贝到剪贴板
With CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
      .SetText strText
      .PutInClipboard
End With
End Sub

Kaohsing · 发表于 2018-6-26 09:06

注：只适合32位机器：Sub main()
Application.ScreenUpdating = False
Dim i%
Dim js As Object
Sheet1.Select
Cells.Clear: [a1:c1] = Split("统计时间在线人数波动值")
For i = 1 To 7
      Set js = CreateObject("MSScriptControl.ScriptControl")
      js.Language = "JavaScript"
      js.AddObject "rg", Range("a2").Offset((i - 1) * 15)
      js.AddCode "function ka(s){  return s.match(/<td>(.*?)(?=<\/td>)/gm);};"
      js.AddObject "y", js.CodeObject.ka(kao(i))
      js.eval ("k=1,l=y.length;for(i=0;i<l;i =i +3){ for (j=0;j<3;j++){rg(k,j+1)=y[i+j].replace(/<td>/,'');};k++;};")
Next
Application.ScreenUpdating = True
MsgBox "job is okey"
End Sub
Function kao(p)
Dim url, parm
url = "http://www.77tj.org/tencent/"
parm = "&__RequestVerificationToken=CfDJ8Oxgi0PF5dtKgteCEWR3ZKKzhWUHnMIkczUHpAA12yTUk-KolOww9ZYTIz6y8-tIfgH2yCgFH-DCVvplmsOa2aRf8VuJtozMmUX_clPPMks-XT6jl3vSufB9_l7nCiRKDdhrvCjTdqPEx7XgPW2-DTk"
With CreateObject("msxml2.xmlhttp")
      .Open "POST", url, False
      .setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
      .send ("PageIndex=" & p & parm)
      kao = VBA.Replace(.responseText, "+", "")
End With
End Function

Kaohsing · 发表于 2018-6-26 09:15

附件：

kaohsing_1.rar (13.6 KB, 下载次数: 8)

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

[求助] 网爬数据最优方案！！！

评分