Makro anpassen

Option Explicit
Sub KombiMagi6_1()
Dim i As Long, u As Double, lngR As Long
Dim n As Byte, k As Byte, j As Byte
Dim vSrc, t!
t = Timer
'Einträge:
vSrc = Array(19, 23, 29, 31, 37, 41, 43, 47, 53, 59, 61, 67, 71, 73, _
79, 83, 89, 97, 101, 103, 107, 109, 113, 127, 131, 137, 139, 149, 151, 157)
k = 5
n = UBound(vSrc) + 1
If k > n Then MsgBox "k > n", 16: Exit Sub
With Application
u = .Fact(n) / (.Fact(k) * .Fact(n - k))
End With
If u > Rows.Count Then MsgBox u & " > " & Rows.Count, 16: Exit Sub
ReDim vRes(k - 1)
ReDim bPos(k - 1) As Byte
For i = 1 To k
bPos(i - 1) = i
Next
Application.ScreenUpdating = False
With ActiveSheet
.Cells.Delete
For i = 1 To u
lngR = lngR + 1
For j = 0 To UBound(bPos)
vRes(j) = vSrc(bPos(j) - 1)
Next
.Range(.Cells(lngR, 1), .Cells(lngR, k)).Value = vRes
Call GetComb(n, k, bPos)
Next
End With
Application.ScreenUpdating = True
MsgBox "fertig in " & Round(Timer - t, 2) & " Sek "
End Sub
Sub GetComb(ByVal n As Byte, ByVal k As Byte, bPos() As Byte)
Dim i As Byte, j As Byte
i = k - 1
Do While bPos(i) >= n - k + i + 1
If i = 0 Then Exit Do
i = i - 1
Loop
bPos(i) = bPos(i) + 1
For j = i To k - 1
bPos(j) = bPos(i) + j - i
Next
End Sub