run time error 5 in parsing site programm

47 Views Asked by At

I have a program (parsing the site) that worked well. But now it gives an error :

Run-time error 5
Invalid procedure call or argument

In line:

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

Full 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\Адаптация к сайту\таблица.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, "<!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 odRange = book1.ActiveSheet.Cells(34, 2).Resize(iRows - 1, iCols - 1)
    odRange.NumberFormat = "@"
    odRange.Value = vata
    
    
    Set odRange = Nothing
    
   
End Function

I tried to change language in Windows - no result. Maybe the problem is that something changed in code of the site. The link of the site: https://allscores.club/soccer/new_ftour.php?champ=4604&f_team=412

0

There are 0 best solutions below