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.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