紧急~~VB抓取网页数据

1229775691

QCW911 发表于 2016-8-8 17:19
你的了解javascript

请帮助看看这个脚本能运行吗？


Option Explicit
Sub test()
    Dim HTML, tb, i&, j&, x&, n&, s$
    [a2:d9999] = ""
    Set HTML = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        For x = 0 To 1
            .Open "get", "https:（增加//)partners.uber.com.cn/p3/crc/dashboard" & 30 * x, False
            .Send
            Application.Wait (Now + TimeValue("00:00:02"))
            HTML.body.innerhtml = .responsetext
            Set tb = HTML.ALL.tags("table")(5).Rows
            For i = 1 To tb.Length - 1
                n = n + 1
                For j = 0 To tb(i).Cells.Length - 1
                    Cells(n + 1, j + 1) = tb(i).Cells(j).innertext
                Next
            Next
        Next
    End With
    MsgBox
End Sub

1229775691

su45 发表于 2016-8-6 19:25
在WPS中运行正常

请帮助看看这个脚本能运行吗？ 目前会在下面蓝色部分出现问题，我把0以此改为1，2 , 3, 4, 5, 6 都没效果~~~


Option Explicit
Sub test()
    Dim HTML, tb, i&, j&, x&, n&, s$
    [a2:d9999] = ""
    Set HTML = CreateObject("htmlfile")
    With CreateObject("msxml2.xmlhttp")
        For x = 0 To 1
            .Open "get", "https:（增加//)partners.uber.com.cn/p3/crc/dashboard" & 30 * x, False
            .Send
            Application.Wait (Now + TimeValue("00:00:02"))
            HTML.body.innerhtml = .responsetext
            Set tb = HTML.ALL.tags("table")(0).Rows
            For i = 1 To tb.Length - 1
                n = n + 1
                For j = 0 To tb(i).Cells.Length - 1
                    Cells(n + 1, j + 1) = tb(i).Cells(j).innertext
                Next
            Next
        Next
    End With
    MsgBox
End Sub

su45

对抓网页不太熟，帮不了你，抱歉。

爱疯

https://partners.uber.com.cn/p3/crc/dashboard300
打不开，网址是正确的吗？


Set tb = HTML.ALL.tags("table")(0).Rows
其中的0，表示第1个表格。
有必要改为1，2 , 3, 4, 5, 6吗？该网页中除第1个表格，还真第2 , 3, 4, 5, 6个表格吗

1229775691

爱疯 发表于 2016-8-9 10:20
https://partners.uber.com.cn/p3/crc/dashboard300
打不开，网址是正确的吗？

是正确的，但可能你需要登录。
https:（增加//)partners.uber.com.cn
我怎么发登录名称和密码给你呢？我不想在贴上面写上登录名字和密码？

1229775691

爱疯 发表于 2016-8-9 10:20
https://partners.uber.com.cn/p3/crc/dashboard300
打不开，网址是正确的吗？

你可以加我位好友吗？？我把用户名和密码发给你！谢谢！

1229775691

叫我赵日天 发表于 2016-8-6 13:08
Set tb = HTML.ALL.tags("table")(2).Rows

你这个把0改为2是如何理解的？？？请帮助~~~紧急~~

ghostjiao

右键  查看网页源码  搜table

table是网页元素  正常是成对出现的  你要的数据在那个网页的第三table里面，元素是从0开始的，所以是2

1229775691

ghostjiao 发表于 2016-8-9 13:57
右键  查看网页源码  搜table

table是网页元素  正常是成对出现的  你要的数据在那个网页的第三table里面 ...

非常感谢！这个已经明白了！

能帮助我看看这个https:（增加//)partners.uber.com.cn/p3/crc/dashboard网页的抓取数据？？

利用下面的语句可以实现吗？这个需要登录和密码，是否可以加我把密码告诉你~~帮组解决一下~~很紧急~~非常感激！

请帮助看看这个脚本能运行吗？ Option Explicit Sub test()     Dim HTML, tb, i&, j&, x&, n&, s$     [a2:d9999] = ""     Set HTML = CreateObject("htmlfile")     With CreateObject("msxml2.xmlhttp")         For x = 0 To 1             .Open "get", "https:（增加//)partners.uber.com.cn/p3/crc/dashboard" & 20 * x, False             .Send             Application.Wait (Now + TimeValue("00:00:02"))             HTML.body.innerhtml = .responsetext             Set tb = HTML.ALL.tags("table")(0).Rows             For i = 1 To tb.Length - 1                 n = n + 1                 For j = 0 To tb(i).Cells.Length - 1                     Cells(n + 1, j + 1) = tb(i).Cells(j).innertext                 Next             Next         Next     End With     MsgBox End Sub

爱疯

'http://www.excelpx.com/thread-38841-1-1.html
'功能：获取url中网页的源代码
Private Function GetSource(sURL As String)
    Dim oXHTTP As Object
    Set oXHTTP = CreateObject("MSXML2.XMLHTTP")
    oXHTTP.Open "GET", sURL, False
    oXHTTP.Send
    GetSource = oXHTTP.responsetext
    Set oXHTTP = Nothing
End Function

'http://www.excelpx.com/thread-423238-1-1.html
'需求：获取第1页到第3页的数据
Sub test()
    Dim HTML As Object
    Dim trs As Object
    Dim Page As Integer
    Dim i As Long
    Dim j As Long

    Application.ScreenUpdating = False
    Cells.ClearContents
    '1）创建 HTMLDocument对象
    Set HTML = CreateObject("htmlfile")

    For Page = 1 To 3

        '2）将URL的源代码，封装为HTMLDocument对象
        HTML.body.innerhtml = GetSource("http://fz.people.com.cn/skygb/sk/index.php/Index/seach?&p=" & Page)

        '3）通过分析网页，知需获取第3个表格
        Set trs = HTML.ALL.tags("table")(2).Rows

        '4）遍历该表格里的行对象集合
        ReDim arr(1 To trs.Length - 1, 1 To trs(0).Cells.Length)
        For i = 1 To UBound(arr)
            For j = 1 To UBound(arr, 2)
                arr(i, j) = trs(i).Cells(j - 1).innertext
            Next j
        Next i

        '5）写入excel
        Cells(Rows.Count, 1).End(3).Offset(1, 0).Resize(UBound(arr), UBound(arr, 2)) = arr
    Next Page

End Sub



这是学习后，加的注释。