Sub test()
Dim tablica(), i As Integer, j As Integer, k As Integer, wynik As String, pozycja As Integer
i = InputBox("Podaj liczbę elementów, z których ma sie odbyć losowanie.", , 49)
j = InputBox("Podaj liczbę elementów losowanych.", , 6)
ReDim tablica(1 To i)
Randomize
For k = 1 To i
tablica(k) = Rnd
Next k
For k = 1 To j
pozycja = WorksheetFunction.Match(WorksheetFunction.Large(tablica, 1), tablica, 0)
wynik = wynik & Chr(10) & pozycja
tablica(pozycja) = 0
Next k
'Range("A1:A" & j + 1) = Application.Transpose(Split(wynik, Chr(10)))
MsgBox "wyniki losowania " & j & " elementów z " & i & wynik
End Sub

Sub Lotto_moegliche_Kombinationen()
Dim i As Byte, j As Byte, k As Byte, l As Byte, m As Byte, n As Byte
Dim c As Integer, r As Long
r = 1
c = 1
Application.ScreenUpdating = False
For i = 1 To 49
  For j = i + 1 To 49
    For k = j + 1 To 49
      For l = k + 1 To 49
        For m = l + 1 To 49
          For n = m + 1 To 49
            Cells(r, c) = i & " " & j & " " & k & " " & l & " " & m & " " & n
            r = r + 1
            If r > 65536 Then
              Application.ScreenUpdating = True
              c = c + 1
              r = 1
              ThisWorkbook.Save
              If c > 256 Then
                c = 1
                Worksheets.Add
              End If
              Application.ScreenUpdating = False
            End If
          Next
        Next
      Next
    Next
  Next
Next
End Sub

Option Explicit

Dim Nb As Integer, NbRange As Range
Dim A As Integer, B As Integer, C As Integer, D As Integer
Dim I As Integer, J As Integer, sTxt(4845) As String

Sub Do_PTQ()
' Display all possible pairs, triples and quads
' based on a maximum of numbers
' Show Pairs
Set NbRange = Range("A2:A21")
Nb = Application.WorksheetFunction.CountA(NbRange)
Range("A1").Select
I = 1
For A = 1 To Nb - 1
For B = A + 1 To Nb
sTxt(I) = ActiveCell.Offset(A, 0).Value & "--" & ActiveCell.Offset(B, 0).Value
I = I + 1
Next B
Next A
For J = 1 To I - 1
ActiveCell.Offset(J, 1).Value = sTxt(J)
Next J
' Show Triples
I = 1
For A = 1 To Nb - 2
For B = A + 1 To Nb - 1
For C = B + 1 To Nb
sTxt(I) = ActiveCell.Offset(A, 0).Value & "--" & ActiveCell.Offset(B, 0).Value _
& "--" & ActiveCell.Offset(C, 0).Value
I = I + 1
Next C
Next B
Next A
For J = 1 To I - 1
ActiveCell.Offset(J, 2).Value = sTxt(J)
Next J
' Show Quads
I = 1
For A = 1 To Nb - 3
For B = A + 1 To Nb - 2
For C = B + 1 To Nb - 1
For D = C + 1 To Nb
sTxt(I) = ActiveCell.Offset(A, 0).Value & "--" & ActiveCell.Offset(B, 0).Value _
& "--" & ActiveCell.Offset(C, 0).Value & "--" & ActiveCell.Offset(D, 0).Value
I = I + 1
Next D
Next C
Next B
Next A
For J = 1 To I - 1
ActiveCell.Offset(J, 3).Value = sTxt(J)
Next J
End Sub

Option Explicit
 
Dim vAllItems As Variant
Dim Buffer() As String
Dim BufferPtr As Long
Dim Results As Worksheet
 '
 ' Myrna Larson, July 25, 2000, Microsoft.Public.Excel.Misc
 
Sub ListPermutationsOrCombinations()
    Dim Rng As Range
    Dim PopSize As Integer
    Dim SetSize As Integer
    Dim Which As String
    Dim n As Double
    Const BufferSize As Long = 4096
     
    Worksheets("Arkusz1").Range("A1").Select
    Set Rng = Selection.Columns(1).Cells
    If Rng.Cells.Count = 1 Then
        Set Rng = Range(Rng, Rng.End(xlDown))
    End If
     
    PopSize = Rng.Cells.Count - 2
    If PopSize < 2 Then GoTo DataError
     
    SetSize = Rng.Cells(2).Value
    If SetSize > PopSize Then GoTo DataError
     
    Which = UCase$(Rng.Cells(1).Value)
    Select Case Which
    Case "C"
        n = Application.WorksheetFunction.Combin(PopSize, SetSize)
    Case "P"
        n = Application.WorksheetFunction.Permut(PopSize, SetSize)
    Case Else
        GoTo DataError
    End Select
    If n > Cells.Count Then GoTo DataError
     
    Application.ScreenUpdating = False
     
    Set Results = Worksheets.Add
     
    vAllItems = Rng.Offset(2, 0).Resize(PopSize).Value
    ReDim Buffer(1 To BufferSize) As String
    BufferPtr = 0
     
    If Which = "C" Then
        AddCombination PopSize, SetSize
    Else
        AddPermutation PopSize, SetSize
    End If
    vAllItems = 0
     
    Application.ScreenUpdating = True
    Exit Sub
     
DataError:
    If n = 0 Then
        Which = "Enter your data in a vertical range of at least 4 cells." _
        & String$(2, 10) _
        & "Top cell must contain the letter C or P, 2nd cell is the Number" _
        & "of items in a subset, the cells below are the values from Which" _
        & "the subset is to be chosen."
         
    Else
        Which = "This requires " & Format$(n, "#,##0") & _
        " cells, more than are available on the worksheet!"
    End If
     MsgBox Which, vbOKOnly, "DATA ERROR"
    Exit Sub
End Sub

Private Sub AddPermutation(Optional PopSize As Integer = 0, _
    Optional SetSize As Integer = 0, _
    Optional NextMember As Integer = 0)
     
    Static iPopSize As Integer
    Static iSetSize As Integer
    Static SetMembers() As Integer
    Static Used() As Integer
    Dim i As Integer
     
    If PopSize <> 0 Then
        iPopSize = PopSize
        iSetSize = SetSize
        ReDim SetMembers(1 To iSetSize) As Integer
        ReDim Used(1 To iPopSize) As Integer
        NextMember = 1
    End If
     
    For i = 1 To iPopSize
        If Used(i) = 0 Then
            SetMembers(NextMember) = i
            If NextMember <> iSetSize Then
                Used(i) = True
                AddPermutation , , NextMember + 1
                Used(i) = False
            Else
                SavePermutation SetMembers()
            End If
        End If
    Next i
     
    If NextMember = 1 Then
        SavePermutation SetMembers(), True
        Erase SetMembers
        Erase Used
    End If
     
End Sub 'AddPermutation
 
Private Sub AddCombination(Optional PopSize As Integer = 0, _
    Optional SetSize As Integer = 0, _
    Optional NextMember As Integer = 0, _
    Optional NextItem As Integer = 0)
     
    Static iPopSize As Integer
    Static iSetSize As Integer
    Static SetMembers() As Integer
    Dim i As Integer
     
    If PopSize <> 0 Then
        iPopSize = PopSize
        iSetSize = SetSize
        ReDim SetMembers(1 To iSetSize) As Integer
        NextMember = 1
        NextItem = 1
    End If
     
    For i = NextItem To iPopSize
        SetMembers(NextMember) = i
        If NextMember <> iSetSize Then
            AddCombination , , NextMember + 1, i + 1
        Else
            SavePermutation SetMembers()
        End If
    Next i
     
    If NextMember = 1 Then
        SavePermutation SetMembers(), True
        Erase SetMembers
    End If
     
End Sub 'AddCombination
 
Private Sub SavePermutation(ItemsChosen() As Integer, _
    Optional FlushBuffer As Boolean = False)
     
    Dim i As Integer, sValue As String
    Static RowNum As Long, ColNum As Long
     
    If RowNum = 0 Then RowNum = 1
    If ColNum = 0 Then ColNum = 1
     
    If FlushBuffer = True Or BufferPtr = UBound(Buffer()) Then
        If BufferPtr > 0 Then
            If (RowNum + BufferPtr - 1) > Rows.Count Then
                RowNum = 1
                ColNum = ColNum + 1
                If ColNum > 256 Then Exit Sub
            End If
             
            Results.Cells(RowNum, ColNum).Resize(BufferPtr, 1).Value _
            = Application.WorksheetFunction.Transpose(Buffer())
            RowNum = RowNum + BufferPtr
        End If
         
        BufferPtr = 0
        If FlushBuffer = True Then
            Erase Buffer
            RowNum = 0
            ColNum = 0
            Exit Sub
        Else
            ReDim Buffer(1 To UBound(Buffer))
        End If
         
    End If
     
     'construct the next set
    For i = 1 To UBound(ItemsChosen)
        sValue = sValue & ", " & vAllItems(ItemsChosen(i), 1)
    Next i
     
     'and save it in the buffer
    BufferPtr = BufferPtr + 1
    Buffer(BufferPtr) = Mid$(sValue, 3)
End Sub 'SavePermutation