网爬数据最优方案！！！

onlycxb

一碧清蓝 发表于 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

注：只适合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, "&#x2B;", "")
    End With
End Function

Kaohsing

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

2018-6-26 09:14 上传

点击文件名下载附件