Модификация программы для разбора

Question

Есть программа, которая анализирует определенную таблицу с сайта.Работает отлично .Я хочу разобрать другую таблицу с сайта.По номеру тега «таблица» они совпадают.Я пытаюсь использовать ту же программу, но выдает ошибку: Ошибка времени выполнения 91 в строке:

     If oRow.Cells(y).Children.Length > 0 Then

Новая таблица: http://allscores.ru/soccer/fstats.php?champ=2604&team=439&team2=420&tour=110

Старая таблица: http://allscores.ru/soccer/new_ftour.php?champ=2604&f_team=439

Новая таблица: на прикрепленном рисунке

Function extractTable(Ssilka As String, book1 As Workbook, iLoop As Long)
    Dim oDom As Object, oTable As Object, oRow As Object
    Dim iRows As Integer, iCols As Integer
    Dim x As Integer, y As Integer
    Dim data()
    Dim vata()
    Dim tata()
    Dim oHttp As Object
    Dim oRegEx As Object
    Dim sResponse As String
    Dim oRange As Range
    Dim odRange As Range

   ' get page
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    oHttp.Open "GET", Ssilka, False
    oHttp.Send

    ' cleanup response
    sResponse = StrConv(oHttp.responseBody, vbUnicode)
    Set oHttp = Nothing

    sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))

    Set oRegEx = CreateObject("vbscript.regexp")
    With oRegEx
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
        .Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
        sResponse = .Replace(sResponse, "")
    End With
    Set oRegEx = Nothing

    ' create Document from response
    Set oDom = CreateObject("htmlFile")
    oDom.Write sResponse
    DoEvents

    ' table with results, indexes starts with zero
    Set oTable = oDom.getelementsbytagname("table")(3)

    DoEvents

    iRows = oTable.Rows.Length
    iCols = oTable.Rows(1).Cells.Length

    ' first row and first column contain no intresting data
    ReDim data(1 To iRows - 1, 1 To iCols - 1)
    ReDim vata(1 To iRows - 1, 1 To iCols - 1)
    ReDim tata(1 To iRows - 1, 1 To iCols - 1)
    ' fill in data array
    For x = 1 To iRows - 1
        Set oRow = oTable.Rows(x)
        For y = 1 To iCols - 1
            If oRow.Cells(y).Children.Length > 0 Then
                data(x, y) = oRow.Cells(y).getelementsbytagname("a")(0).getattribute("href")
                data(x, y) = Replace(data(x, y), "about:", "http://allscores.ru/soccer/")
                vata(x, y) = oRow.Cells(y).innerText
            End If
        Next y
    Next x

    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing

    Set oRange = book1.ActiveSheet.Cells(110, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
    oRange.NumberFormat = "@"
    oRange.Value = data

    Set odRange = book1.ActiveSheet.Cells(34, 26 + (iLoop * 21)).Resize(iRows - 1, iCols - 1)
    odRange.NumberFormat = "@"
    odRange.Value = vata

    Set oRange = Nothing
    Set odRange = Nothing

End Function

Answer 1

Это не особенно надежно, но захватывает значения из таблицы.iLoop не используется.

Option Explicit
Public Sub test()    
    extractTable "http://allscores.ru/soccer/fstats.php?champ=2604&team=439&team2=420&tour=110", ThisWorkbook, 1    
End Sub

Public Sub extractTable(Ssilka As String, book1 As Workbook)
    Dim oDom As Object, oTable As Object
    Dim oHttp As Object
    Dim oRegEx As Object
    Dim sResponse As String
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    oHttp.Open "GET", Ssilka, False
    oHttp.send
    sResponse = StrConv(oHttp.responseBody, vbUnicode)
    Set oHttp = Nothing

    sResponse = Mid$(sResponse, InStr(1, sResponse, "<!DOCTYPE "))

    Set oRegEx = CreateObject("vbscript.regexp")
    With oRegEx
        .MultiLine = True
        .Global = True
        .IgnoreCase = False
        .Pattern = "<(script|SCRIPT)[\w\W]+?</\1>"
        sResponse = .Replace(sResponse, "")
    End With
    Set oRegEx = Nothing
    Set oDom = CreateObject("htmlFile")
    oDom.Write sResponse

    Set oTable = oDom.getElementsByTagName("table")(3)

    Dim b As Object, a As Object
    Set b = oTable.getElementsByTagName("TR")    'DispHTMLElementCollection

    Dim i As Long, y As Long
    With ActiveSheet
        For i = 3 To 17 '17-3 gives the 15 rows of interest. Start at 3 to avoid header and empty row.
            Set a = b(i).ChildNodes
            For y = 1 To a.Length - 1
                .Cells(i - 2, y) = a(y).innerText
            Next y
        Next i
    End With
End Sub