Option Explicit

Sub main()
    Dim r As Range
    Dim firstAddress As String
    Dim iLoop As Long
    Dim book1 As Workbook
    Dim sheetNames(1 To 19) As String
    
    sheetNames(1) = "Лист1"
    sheetNames(2) = "Лист2"
    sheetNames(3) = "Лист3"
    sheetNames(4) = "Лист4"
    sheetNames(5) = "Лист5"
    sheetNames(6) = "Лист6"
    sheetNames(7) = "Лист7"
    sheetNames(8) = "Лист8"
    sheetNames(9) = "Лист9"
    sheetNames(10) = "Лист10"
    sheetNames(11) = "Лист11"
    sheetNames(12) = "Лист12"
    sheetNames(13) = "Лист13"
    sheetNames(14) = "Лист14"
    sheetNames(15) = "Лист15"
    sheetNames(16) = "Лист16"
    sheetNames(17) = "Лист17"
    sheetNames(18) = "Лист18"
    sheetNames(19) = "Лист19"
    
    Set book1 = Workbooks.Open("E:\Super M\Проект ставки\Поиск решения\Усов 4\прога для книга\21.xlsx")
    book1.Worksheets("21").Range("U33:U99") = book1.Worksheets("21").Range("U33:U99").Value
    book1.Save
    book1.Close
    
    With Workbooks.Open("E:\Super M\Проект ставки\Поиск решения\Усов 4\прога для книга\21.xlsx").Worksheets("21").Range("U33:U99") '<--| open wanted workbook and refer to cells "U33:U99" in its worksheet "7"
          
        Set r = .Find(What:="1") '<--| the Find() method is called on the range referred to in the preceding With statement
        If Not r Is Nothing Then
            firstAddress = r.Address
            Do
                iLoop = iLoop + 1 '<-- update loop counter
                .Parent.Parent.Worksheets(sheetNames(iLoop)).Cells(1, 1).Value = r.Offset(, -16).Hyperlinks.Item(1).Address '<--| write into proper worksheet whose name is taken from sheetNames array at index corresponding to current loop
                Set r = .FindNext(r) '<--| the FindNext() method is still called on the same range as in the preceding  .Find() statement
            Loop While Not r Is Nothing And r.Address <> firstAddress And iLoop < 19 '<--| exit loop if either you hit the first link or completed three loops
        End If
    End With
End Sub

Option Explicit

Sub extractTable_3()
    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 oHttp As Object
    Dim oRegEx As Object
    Dim sResponse As String
    Dim oRange As Range
    
    ' get page
    Set oHttp = CreateObject("MSXML2.XMLHTTP")
    oHttp.Open "GET", "http://allscores.ru/soccer/new_ftour.php?champ=1110&f_team=1015", 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)
    
    ' fill in data array
    For x = 1 To iRows - 1
        Set oRow = oTable.Rows(x)
        
        For y = 1 To iCols - 1
            data(x, y) = oRow.Cells(y).innerText
        Next y
    Next x
    
    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing
    
    ' put data array on worksheet
    Set oRange = ThisWorkbook.Worksheets(1).Cells(34, 2).Resize(iRows - 1, iCols - 1)
    oRange.NumberFormat = "@"
    oRange.Value = data
    Set oRange = Nothing
    
    '<DEBUG>
'    For x = LBound(data) To UBound(data)
'        Debug.Print x & ":[ ";
'        For y = LBound(data, 2) To UBound(data, 2)
'            Debug.Print y & ":[" & data(x, y) & "] ";
'        Next y
'        Debug.Print "]"
'    Next x
    '</DEBUG>
    
End Sub

Option Explicit

Sub main()
    Dim r As Range
    Dim firstAddress As String
    Dim iLoop As Long
    Dim book1 As Workbook
    Dim sheetNames(1 To 19) As String
    Dim Ssilka As Variant
    
    sheetNames(1) = "Лист1"
    sheetNames(2) = "Лист2"
    sheetNames(3) = "Лист3"
    sheetNames(4) = "Лист4"
    sheetNames(5) = "Лист5"
    sheetNames(6) = "Лист6"
    sheetNames(7) = "Лист7"
    sheetNames(8) = "Лист8"
    sheetNames(9) = "Лист9"
    sheetNames(10) = "Лист10"
    sheetNames(11) = "Лист11"
    sheetNames(12) = "Лист12"
    sheetNames(13) = "Лист13"
    sheetNames(14) = "Лист14"
    sheetNames(15) = "Лист15"
    sheetNames(16) = "Лист16"
    sheetNames(17) = "Лист17"
    sheetNames(18) = "Лист18"
    sheetNames(19) = "Лист19"
    
    Set book1 = Workbooks.Open("E:\Super M\Проект ставки\Поиск решения\Усов 4\прога для книга\21.xlsx")
    book1.Worksheets("21").Range("U33:U99") = book1.Worksheets("21").Range("U33:U99").Value
    book1.Save
    book1.Close
    
    With Workbooks.Open("E:\Super M\Проект ставки\Поиск решения\Усов 4\прога для книга\21.xlsx").Worksheets("21").Range("U33:U99") '<--| open wanted workbook and refer to cells "U33:U99" in its worksheet "7"
          
        Set r = .Find(What:="1") '<--| the Find() method is called on the range referred to in the preceding With statement
        If Not r Is Nothing Then
            firstAddress = r.Address
            Do
                iLoop = iLoop + 1 '<-- update loop counter
                .Parent.Parent.Worksheets(sheetNames(iLoop)).Activate
                 Ssilka = r.Offset(, -16).Hyperlinks.Item(1).Address
                  extractTable_3 (Ssilka)
                
                Set r = .FindNext(r) '<--| the FindNext() method is still called on the same range as in the preceding  .Find() statement
            Loop While Not r Is Nothing And r.Address <> firstAddress And iLoop < 19 '<--| exit loop if either you hit the first link or completed three loops
        End If
    End With
End Sub

Function extractTable_3(Ssilka As Variant) As Variant
    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 oHttp As Object
    Dim oRegEx As Object
    Dim sResponse As String
    Dim oRange As Range
    Dim book1 As Workbook
    
    ' 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)
    
    ' fill in data array
    For x = 1 To iRows - 1
        Set oRow = oTable.Rows(x)
        
        For y = 1 To iCols - 1
            data(x, y) = oRow.Cells(y).innerText
        Next y
    Next x
    
    Set oRow = Nothing
    Set oTable = Nothing
    Set oDom = Nothing
    
    ' put data array on worksheet
    Set book1 = Workbooks.Open("E:\Super M\Проект ставки\Поиск решения\Усов 4\прога для книга\21.xlsx")
    Set oRange = book1.ActiveWorksheet.Cells(34, 2).Resize(iRows - 1, iCols - 1)
    oRange.NumberFormat = "@"
    oRange.Value = data
    Set oRange = Nothing
    
    
    '<DEBUG>
'    For x = LBound(data) To UBound(data)
'        Debug.Print x & ":[ ";
'        For y = LBound(data, 2) To UBound(data, 2)
'            Debug.Print y & ":[" & data(x, y) & "] ";
'        Next y
'        Debug.Print "]"
'    Next x
    '</DEBUG>

End Function

 Set oRange = book1.ActiveWorksheet.Cells(34, 2).Resize(iRows - 1, iCols - 1)

Set r = .FindNext(r) 

iLoop = iLoop + 1 '<-- update loop counter
                .Parent.Parent.Worksheets(sheetNames(iLoop)).Activate