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 book2 As Workbook
    Dim Ssilka As String
    Dim A As Long
    Dim S As Long
    Dim t As Long
    Dim W
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    
    W = Array("прошлый", "допрошлый", "додопрошлый")
   
For S = 1 To 2
 Set book1 = Workbooks.Open("E:\Поиск решения\Усов 7\вспомогательные программы\3 сезона\" + W(S) + "\таблица.xlsm")
  For t = 1 To 98
    Set book2 = Workbooks.Open("E:\Поиск решения\Усов 7\вспомогательные программы\3 сезона\" + W(S) + "\" & t & ".xlsm")
   
     
        With book1.Worksheets("таблица").Range("AF34:AF53")
           iLoop = 0
             For Each r In .Rows
              
            If r.Value = 5 Then
                  iLoop = iLoop + 1
                  Ssilka = r.Offset(0, -30).Hyperlinks.Item(1).Address
                  book2.Worksheets("Лист" & iLoop).Activate
                  extractTable Ssilka, book2, iLoop
              End If
            Next r
        End With

  book2.Save
  book2.Close
   Next t
     book1.Close
 Next S
 
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Application.EnableEvents = True
  
   End Sub


Function extractTable(Ssilka As String, book2 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 = book2.ActiveSheet.Cells(110, 2).Resize(iRows - 1, iCols - 1)
    oRange.NumberFormat = "@"
    oRange.Value = data
    
    Set odRange = book2.ActiveSheet.Cells(34, 2).Resize(iRows - 1, iCols - 1)
    odRange.NumberFormat = "@"
    odRange.Value = vata
    
    
    Set odRange = Nothing
    
   
End Function