VBA randomly selecting multiple rows

Question

Hi dear Excel community

i have before asked a question about how to list all 7 digits combination of 34 integers (1-34) and got a good solution by Andreas Killer.  i got the code below that fixed my problem. but i have a new problem/question. Can anyone help me to write code that can randomlyselect multiple rows? let say 1000 rows from the result of this code and rewrite it in a new worksheet? 

thanks in advance!

Option Explicit

Sub Main()

  Dim Data, Item

  Dim C As Collection

  Dim i As Long, j As Long

  ReDim Data(1 To 34)

  For i = LBound(Data) To UBound(Data)

    Data(i) = i

  Next

  Set C = Combinations(Data, 7)

  Application.ScreenUpdating = False

  i = 1

  j = 1

  For Each Item In C

    If i > Rows.Count Then

      i = 1

      j = j + 1

    End If

    Cells(i, j) = Join(Item, ",")

    i = i + 1

  Next

End Sub

Private Function Combinations(Arr, ByVal Count As Integer) As Collection

  'Gibt alle Kombinationen von Count Elementen in Arr als Arrays in einer Collection zurück

  'Returns all combinations of Count elements in Arr as arrays in a collection

  Dim Index() As Long

  Dim Result()

  Dim i As Long, j As Integer

  'Create a collection

  Set Combinations = New Collection

  'Return empty collection if Count exceed the bound's of Arr

  If LBound(Arr) + Count - 1 > UBound(Arr) Or Count < 1 Then Exit Function

  'Setup space for index and result array

  ReDim Index(1 To Count) As Long

  ReDim Result(1 To Count)

  'Setup index for first combination

  For i = 1 To Count

    Index(i) = LBound(Arr) + i - 1

  Next

  Do

    'Build combination

    For i = 1 To Count

      Result(i) = Arr(Index(i))

    Next

    'Save it

    Combinations.Add Result

    'Get next index

    i = Count

    j = 0

    Do

      'Max. position for this index reached?

      If Index(i) = UBound(Arr) - Count + i Then

        j = j + 1

        'Move index before up one step in next loop

        i = i - 1

        If i < 1 Then Exit Function

      Else

        'Increment position

        Index(i) = Index(i) + 1

        'Setup next indices

        For j = 1 To j

          i = i + 1

          Index(i) = Index(i - 1) + 1

        Next

        Exit Do

      End If

    Loop

  Loop

End Function

Answer 1

Hi QorbanAli,

My name is Alex. I am an - Independent Consultant.

It is an honor to respond to your participation in the Microsoft community!

In this site you can review this code https://developer.microsoft.com/en-us/office/su...

Click on "Ask a Question" and post your code.

Please let me know if this does not work or if you've tried this already.

Best regards, Alex