Random Selection of Rows

[rangequestion]

Hi,
I Have the code below that randomly selects 5% of rows in the active worksheet and pastes it to another. The problem is that this macro delivers duplicate rows. Is there any way to edit the code to ensure duplicates are not in the new worksheet?

Thanks

Sub RandSelect()
Dim Qty As Long
Dim UsdRws As Long
Dim Rw As Long
Dim MasterSht As Worksheet
Dim NewSht As Worksheet
Set MasterSht = ActiveSheet
UsdRws = Cells.Find("*", after:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "QC Sample"
Set NewSht = Sheets("QC Sample")
MasterSht.Rows(1).Copy NewSht.Range("A1")
Qty = Int(0.05 * UsdRws)

Do While Qty > 0
Rw = WorksheetFunction.RandBetween(2, UsdRws)
MasterSht.Rows(Rw).Copy NewSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
Qty = Qty - 1
Loop

End Sub​

 

[jmacleary]

Hi there.

I have added an array to save used rows, see code below.

Sub RandSelect()
Dim Qty As Long
Dim UsdRws As Long
Dim Rw As Long
Dim MasterSht As Worksheet
Dim NewSht As Worksheet
Set MasterSht = ActiveSheet
Dim UsedIndex As Long
Dim Looper As Long
Dim Dup As Boolean
UsdRws = Cells.Find("*", after:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row

Sheets.Add(after:=Sheets(Sheets.Count)).Name = "QC Sample"
Set NewSht = Sheets("QC Sample")
MasterSht.Rows(1).Copy NewSht.Range("A1")
Qty = Int(0.05 * UsdRws)
ReDim Used(Qty)
UsedIndex = 0
Do While Qty > 0
Rw = WorksheetFunction.RandBetween(2, UsdRws)
Dup = False
For Looper = 0 To UsedIndex
If Used(Looper) = Rw Then
Qty = Qty + 1
Dup = True
MsgBox Rw
Exit For

End If
Next Looper

If Not Dup Then
MasterSht.Rows(Rw).Copy NewSht.Range("A" & Rows.Count).End(xlUp).Offset(1)
Used(UsedIndex) = Rw
UsedIndex = UsedIndex + 1
End If
Qty = Qty - 1
Loop

End Sub

 

[rangequestion]

Yes! Thanks!