How to randomly select number of rows based on conditions in Excel?

Question

I want to randomly select 50 rows from one sheet and pasting them in a separate workbook for data sampling. I don't know how to do it because first, I'm new to VBA, I want to learn something new and second, I tried searching this on Google but no accurate answer found.

So what's on my mind is this:

1. I'll get first the number of rows in that worksheet. I've already done it with this one line of code:
   CountRows = ActiveSheet.Cells(ActiveSheet.Rows.Count, "A").End(xlUp).Row

2. Get a random number from 1 to CountRows uniquely. The random numbers should be incremental (1,5,7,20,28,30,50 and no backward counting). Then grab that row, create a new workbook if not yet open and paste it there.

How can I achieve this process? I have no idea how to start this.

Answer 1

Following code will do what you need.

Sub Demo()
    Dim lng As Long
    Dim tempArr() As String
    Dim srcWB As Workbook, destWB As Workbook
    Dim rng As Range
    Dim dict As New Scripting.Dictionary
    Const rowMax As Long = 100 'maximum number of rows in source sheet
    Const rowMin As Long = 1   'starting row number to copy
    Const rowCopy As Long = 50 'number of rows to copy
    Dim intArr(1 To rowCopy) As Integer, rowArr(1 To rowCopy) As Integer
    Set srcWB = ThisWorkbook

    'get unique random numbers in dictionary
    With dict
        Do While .Count < rowCopy
            lng = Rnd * (rowMax - rowMin) + rowMin
            .Item(lng) = Empty
        Loop
        tempArr = Split(Join(.Keys, ","), ",")
    End With

    'convert random numbers to integers
    For i = 1 To rowCopy
        intArr(i) = CInt(tempArr(i - 1))
    Next i

    'sort random numbers
    For i = 1 To rowCopy
        rowArr(i) = Application.WorksheetFunction.Small(intArr, i)
        If rng Is Nothing Then
            Set rng = srcWB.Sheets("Sheet1").Rows(rowArr(i))
        Else
            Set rng = Union(rng, srcWB.Sheets("Sheet1").Rows(rowArr(i)))
        End If
    Next i

    'copy random rows, change sheet name and destination path as required
    Set destWB = Workbooks.Add
    With destWB
        rng.Copy destWB.Sheets("Sheet1").Range("A1")
        .SaveAs Filename:="D:\Book2.xls", FileFormat:=56
    End With
End Sub

Above code uses Dictionary so you have to add reference to Microsoft Scripting Runtime Type Library. In Visual Basic Editor, go to Tools->References and check "Microsoft Scripting Runtime" in the list.

Let me know if anything is not clear.

Answer 2

First, generate an array of 50 unique numbers between 1 and CountRows, using this routine:

' Generate a sorted array(0 to count-1) numbers between a and b inclusive
Function UniqueRandom(ByVal count As Long, ByVal a As Long, ByVal b As Long) As Long()
  Dim i As Long, j As Long, x As Long
  ReDim arr(b - a) As Long

  Randomize
  For i = 0 To b - a:    arr(i) = a + i:     Next
  If b - a < count Then UniqueRandom = arr:    Exit Function

  For i = 0 To b - a    'Now we shuffle the array
    j = Int(Rnd * (b - a))
    x = arr(i):   arr(i) = arr(j):   arr(j) = x    ' swap
  Next

  ' After shuffling the array, we can simply take the first portion
  ReDim Preserve arr(0 To count - 1)

  'sorting, probably not necessary
  For i = 0 To count - 1
    For j = i To count - 1
      If arr(j) < arr(i) Then x = arr(i):   arr(i) = arr(j):   arr(j) = x   ' swap
    Next
  Next

  UniqueRandom = arr
End Function

Now you can use the above routine to generate random, unique and sorted indexes and copy the corresponding rows. Here's an example:

Sub RandomSamples()
  Const sampleCount As Long = 50
  Dim lastRow As Long, i As Long, ar() As Long, rngToCopy As Range

  With Sheet1
    lastRow = .Cells(.Rows.count, "A").End(xlUp).row
    ar = UniqueRandom(sampleCount, 1, lastRow)
    Set rngToCopy = .Rows(ar(0))
    For i = 1 To UBound(ar)
      Set rngToCopy = Union(rngToCopy, .Rows(ar(i)))
    Next
  End With
  With Workbooks.Add
    rngToCopy.Copy .Sheets(1).Cells(1, 1)
    .SaveAs ThisWorkbook.path & "\" & "samples.xlsx"
    .Close False
  End With
End Sub