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