使用excel VBA不会刮取跨度id值

Question

虽然现在的页面结构没有变化，但我有Excel代码来擦除nowgoal.com最近停止工作的结果

单元格AF2包含“1”控制哪些行数据应该被扫描（基本上每列中添加了数字1的行应该用刮处理）。

每行包含nowgoal ID（http://www.nowgoal.com/analysis/1401651.html - ID为1401651），并且主目标应该被刮到C列，并且每个相应行中的目标到D列）

这是我的代码：

Option Explicit
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal Milliseconds As LongPtr)
Sub GetResult()

Const START_ROW As Integer = 3
Const START_COL As Integer = 3

Const ANALYSIS_PAGE As String = "http://www.nowgoal.com/analysis/"

Dim LString As String, LArray() As String

'get week number
Dim week As Integer: week = ActiveSheet.Cells(2, 32)

'instantiate worksheet to process
Dim wks As Worksheet: Set wks = ActiveSheet

'instantiate browser
Dim ie As New InternetExplorer
ie.Visible = True

'instantiate variables
Dim url As String, i As Integer, j As Integer
Dim nowGoalID As Long, iRow As Long, lastRow As Long

With wks

    lastRow = .Cells(Rows.Count, 1).End(xlUp).Row

    For iRow = START_ROW To lastRow

        'check week
        If .Cells(iRow, 1) <> week Or .Cells(iRow, 2) = "" Then GoTo nextRow
        Application.Goto .Cells(iRow, 1), True
        DoEvents

        nowGoalID = .Cells(iRow, 2)
        Application.StatusBar = "Processing row: " & iRow & " " & nowGoalID

        url = ANALYSIS_PAGE & nowGoalID & ".html"

        ie.navigate url
        While ie.Busy: DoEvents: Sleep 100: Wend
        While ie.readyState <> READYSTATE_COMPLETE: DoEvents: Sleep 100: Wend

        LString = Mid(ie.document.getElementById("mScore").innerText, 8)
        LArray = Split(LString, "-")

        Cells(70, 2).Value = LArray

nextRow:
Next iRow
End With

ie.Quit
Set ie = Nothing
MsgBox "All done", vbInformation
End Sub

宏打开IE并找到合适的网站但是没有完成抓取

Answer 1

我想你可以将id连接成一个ajax xhr

Option Explicit    
Public Sub GetScores()
    Dim arr() As String, ws As Worksheet, ids(), id As Long
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    ids = Array(1692803, 1401651)

    With CreateObject("MSXML2.XMLHTTP")
        For id = LBound(ids) To UBound(ids)
            .Open "GET", "http://www.nowgoal.com/Ajax.aspx?type=24&id=" & ids(id) & "&p=1553884659000", False
            .send
            If .Status = 200 Then
                arr = Split(.responseText, "-")
                ws.Cells(id + 1, "C") = arr(0): ws.Cells(id + 1, "D") = arr(1)
            End If
        Next
    End With
End Sub