downtown1933

This took 26.6250 sec for 25727 rows in Sample List.
So, it may take much longer if you have many rows in both sheets.
Option Explicit

Sub test()
    Dim a, b, i As Long, ii As Long, iii As Long, iv, x
    Dim w, ub As Long, n As Long, t As Long, e
    Const myLimit As Long = 4000
    Application.ScreenUpdating = False
    Sheets("sample results").Cells.ClearContents
    a = Sheets("sample data").Cells(1).CurrentRegion.Value
    ub = UBound(a, 2): x = 1
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1: ReDim w(1 To UBound(a, 2))
        For i = UBound(a, 1) To 1 Step -1
            If Not .Exists(a(i, 1)) Then
                ReDim w(1 To UBound(a, 2), 1 To 1)
            Else
                w = .Item(a(i, 1))
                ReDim Preserve w(1 To UBound(a, 2), 1 To UBound(w, 2) + 1)
            End If
            For ii = 1 To UBound(a, 2)
                w(ii, UBound(w, 2)) = a(i, ii)
            Next
            .Item(a(i, 1)) = w
            t = Application.Max(t, UBound(w, 2) + 1)
        Next
        a = Sheets("sample list").Cells(1).CurrentRegion.Value
        For i = UBound(a, 1) To 1 Step -myLimit
            ReDim b(1 To myLimit * t, 1 To UBound(a, 2) + ub + 1)
            For ii = i To Application.Max(i - myLimit - 1, 1) Step -1
                If .Exists(a(ii, 1)) Then
                    For iii = 1 To UBound(.Item(a(ii, 1)), 2)
                        n = n + 1
                        For iv = 1 To UBound(a, 2)
                            b(n, iv) = a(ii, iv)
                        Next
                        For iv = 1 To UBound(.Item(a(ii, 1)), 1)
                            b(n, ub + iv + 1) = .Item(a(ii, 1))(iv, iii)
                        Next
                    Next
                End If
                n = n + 1
            Next
            Sheets("sample results").Cells(x, 1).Resize(n, UBound(b, 2)).Value = b
            x = x + n + 1: n = 0
        Next
    End With
    Application.ScreenUpdating = True
    Sheets("sample results").Select
End Sub