Sub test()
    Dim s, url, z, t, sd, a, t_li, i, srUrl
    Dim r, l, lr, m, u
    url = "https://tipsterarea.com/teams/england/aston-villa"
    z = GetHTTPResponse(url)
    Set sd = CreateObject("Scripting.Dictionary")
    With CreateObject("HtmlFile")
        .Body.innerHTML = z
        For Each t_li In .GetElementsByTagName("tr")
            If InStr(1, t_li.innerHTML, "First Half", vbTextCompare) > 0 Then
                Debug.Print
                t = t + 1
                Debug.Print t, t_li.innerHTML
            End If
        Next
    End With
End Sub

 1            <TD class=date>09.12.2023</TD>
<TD title="Premier League, season 2023 - 2024" class=tourn><SPAN class=dc><SPAN class=dce>Premier League</SPAN></SPAN></TD>
<TD class="hteam bold"><SPAN class=dc><SPAN class=dce>Aston Villa</SPAN></SPAN></TD>
<TD title="First Half 1 - 0,  Second Half 0 - 0" class="result win">1 - 0</TD>
<TD class=ateam><SPAN class=dc><SPAN class=dce>Arsenal</SPAN></SPAN></TD>
<TD class="odd bold">3.50</TD>
<TD class=odd>3.75</TD>
<TD class=odd>2.08</TD>

 2            <TD class=date>06.12.2023</TD>
<TD title="Premier League, season 2023 - 2024" class=tourn><SPAN class=dc><SPAN class=dce>Premier League</SPAN></SPAN></TD>
<TD class="hteam bold"><SPAN class=dc><SPAN class=dce>Aston Villa</SPAN></SPAN></TD>
<TD title="First Half 0 - 0,  Second Half 1 - 0" class="result win">1 - 0</TD>
<TD class=ateam><SPAN class=dc><SPAN class=dce>Manchester City</SPAN></SPAN></TD>
<TD class="odd bold">4.60</TD>
<TD class=odd>4.26</TD>
<TD class=odd>1.71</TD>

Private Function GetHTTPResponse(ByVal sURL As String) As String
     Dim oXMLHTTP
     On Error Resume Next
     Set oXMLHTTP = CreateObject("MSXML2.XMLHTTP")
     With oXMLHTTP
        .Open "GET", sURL, False
        .SetRequestHeader "Cache-Control", "max-age=0"
        .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; WOW64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/48.0.2564.41 Safari/537.36 OPR/35.0.2066.10 (Edition beta)"
        .SetRequestHeader "Accept-Encoding", "deflate"
        .SetRequestHeader "Accept-Language", "ru-RU,ru;q=0.8,en-US;q=0.6,en;q=0.4"
        .send
         GetHTTPResponse = .responseText
     End With
     Set oXMLHTTP = Nothing
End Function

 pat = ActiveWorkbook.path

        ' Сохраняем новую книгу с уникальным именем
             newWorkbook.SaveAs pat & "\" & name = " " & ".xlsx"
                newWorkbook.Close SaveChanges:=False

             newWorkbook.SaveAs pat & "\" & name & ".xlsx"
                newWorkbook.Close SaveChanges:=False

Sub imho()
    m = Лист1.UsedRange.Value
    ReDim rz(1 To UBound(m) * 2, 1 To 1)
    For r = 1 To UBound(m)
        rz(r * 2 - 1, 1) = m(r, 1)
    Next r
    Cells(1, 4).Resize(UBound(rz)) = rz
End Sub

Option Explicit

Sub qwert()
    Dim r, i, lr, f, o, m1, m2, u, rz, slf: Set slf = CreateObject("Scripting.Dictionary")
    Dim slo: Set slo = CreateObject("Scripting.Dictionary")
    With Worksheets("1")
        lr = .UsedRange.Rows.Count
        m1 = .Cells(1, 1).Resize(lr, 2).Value
    End With
    With Worksheets("2")
        lr = .UsedRange.Rows.Count
        m2 = .Cells(1, 1).Resize(lr, 2).Value
    End With
    For r = 2 To UBound(m2)
        f = m2(r, 2)
        If Len(f) > 0 Then
            slf(f) = m2(r, 1)
        Else
            slo(m2(r, 1)) = r
        End If
    Next r
    ReDim rz(1 To UBound(m1) + UBound(m2), 1 To 3)
    rz(1, 1) = "имя"
    rz(1, 2) = "отчество"
    rz(1, 3) = "фамилия"
    For r = 2 To UBound(m1)
        rz(r, 1) = m1(r, 1)
        f = m1(r, 2)
        If slf.exists(f) Then
            rz(r, 2) = slf(f)
            slf.Remove f
        End If
        rz(r, 3) = m1(r, 2)
    Next r
    If slf.Count > 0 Then
        u = slf.keys
        For i = 0 To UBound(u)
            rz(r, 3) = u(i)
            rz(r, 2) = slf(u(i))
            r = r + 1
        Next i
    End If
    If slo.Count > 0 Then
        u = slo.keys
        For i = 0 To UBound(u)
            rz(r, 2) = u(i)
            r = r + 1
        Next i
    End If
    Worksheets.Add
    Cells(1, 1).Resize(UBound(rz), UBound(rz, 2)) = rz
    Cells(1, 1).Resize(UBound(rz), UBound(rz, 2)).Columns.AutoFit
End Sub

Sub пройти_тест_заново()
    Erase Otvet '
    sl_otvet.RemoveAll '
End Sub

                    Y = k.Row
                    X = k.Column