Why does after the site was rewritten my parsing programm gives me strange result

50 Views Asked by At

I have a program that parses the site (takes one table). The program worked well, but after the site was rewritten, it stopped producing the desired result.

Before

Before

After

After

Code:

Sub Softочки()
Application.DisplayAlerts = False
Call mainмассивы
Application.DisplayAlerts = True
End Sub


Sub mainмассивы()
Dim r As Range
Dim iLoop As Long
Dim book1 As Workbook
Dim Ssilka As String
Dim A As Long

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

Set book1 = Workbooks.Open("D:\Super M\Поиск решения\Усов 9\Разработка\Шапка для болванки ФИН ПРОГИ\таблица.xlsm")
 

 
    With book1.Worksheets("таблица").Range("B34:B53")
       iLoop = 0
         For Each r In .Rows
          
        
              iLoop = iLoop + 1
              Ssilka = r.Hyperlinks.Item(1).Address
              book1.Worksheets("Лист" & iLoop).Activate
              extractTable Ssilka, book1, iLoop
          
        Next r
    End With

 book1.Save
 book1.Close

 Application.ScreenUpdating = True
 Application.Calculation = xlCalculationAutomatic
 Application.EnableEvents = True

 End Sub


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, "<SCRIPT language=JavaScript><!--"))

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")(0)

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.club/league.php")
            vata(x, y) = oRow.Cells(y).innerText
            
        End If

    Next y
Next x

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


Set odRange = book1.ActiveSheet.Cells(34, 2).Resize(iRows - 1, iCols - 1)
odRange.NumberFormat = "@"
odRange.Value = vata


Set odRange = Nothing


End Function

The link of the site:https://allscores.club/league.php?sport=soccer&champ=4804&f_team=412&new_tid=0

A t first the programm gives me an error. Than i changed the number of the table in code. Programm worked, but not correctly.

0

There are 0 best solutions below