Private FOut() As Long
Private FLast As Long
Private FNumbers() As Long
Private FBase(1 To 5) As Long
Private FCurrent(1 To 5) As Long
Public Sub Initialize()
    Dim i As Long, k As Long
    ReDim FOut(1 To 376992, 1 To 5)
    ReDim FNumbers(1 To 36)
    For i = 1 To 36
        FNumbers(i) = i
    Next
    For i = 1 To 5
        FOut(1, i) = i
        FCurrent(i) = i
        FBase(i) = i
    Next
    FLast = 1
    For i = 6 To 36
        FLast = FLast + 1
        For k = 1 To 4
            FOut(FLast, k) = FBase(k)
            FCurrent(k) = FBase(k)
        Next k
        FOut(FLast, 5) = i
        FCurrent(5) = i
        DoWrite 4, i
    Next i

    Range(Cells(1, 1), Cells(376992, 5)).Value = FOut
End Sub

Private Sub DoWrite(ByVal Level As Long, ByVal Pos As Long)
    Dim i As Long, k As Long
    If Level < 1 Then Exit Sub
    For i = FBase(Level) + 1 To Pos - 1
        FCurrent(Level) = i
        FLast = FLast + 1
        For k = 1 To 5
            FOut(FLast, k) = FCurrent(k)
        Next
        DoWrite Level - 1, i
    Next
End Sub

Sub Kombinazii()
Dim a&(), i&, k&, n&, p&, j&
n = [w2]: k = [w1]
ReDim a(1 To k)
ReDim arr(1 To [w3], 1 To [w1])
Application.ScreenUpdating = False
For i = 1 To k - 1
    a(i) = i
Next i
a(k) = k - 1

Range("a1").CurrentRegion.ClearContents
Do
    If a(k) = n Then p = p - 1 Else p = k
    If p = 0 Then Exit Do
    For i = k To p Step -1
        a(i) = a(p) + i - p + 1
    Next i
    j = j + 1: If j > 1048576 Then Exit Do
    For i = 1 To k
        arr(j, i) = a(i)
    Next i
Loop
Cells(1, 1).Resize([w3], [w1]) = arr
Erase arr
Application.ScreenUpdating = True
End Sub