VBA - How do I randomly select 10% of rows from a column, ensuring they are different and put a Y in column B? - excel

Question

I am looking to randomly select 10% of tasks worked by different users ('originator' Column P) and place a Y in column B to allow checkers to QC the work. If the 10% is not a whole number then I am required to round up i.e. 0.8 would require 1 row and 1.3 would require 2 rows.
I am new to coding I have been able to add code to filter the rows to show the required date and the 'Originator' in column P then name this range as "userNames". I am not sure how to code to select the random 10%. I have changed the part I am struggling with to bold below.
Sub randomSelection()
Dim dt As Date
dt = "20/08/2021"
Dim lRow As Long
'Format date
Range("J:J").Select
Selection.NumberFormat = "dd/mm/yyyy"
'Select User Grogu
ActiveSheet.Range("$A$1:$W$10000").AutoFilter 10, Criteria1:="=" & dt
ActiveSheet.Range("$A$1:$W$10000").AutoFilter Field:=16, Criteria1:= _
"SW\Grogu"
'Name range "userNames"
With ActiveSheet
lRow = .Cells(Rows.Count, 16).End(xlUp).Row
If lRow < 3 Then Exit Sub
.Cells(1, 16).Offset(1, 0).Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Select
End With
Selection.Name = "userNames"
**'Randomly select 10% of rows from originator and put a Y in column B**
'remove all defined names
On Error Resume Next
ActiveWorkbook.Names("userNames").Delete
'Select User Finn
ActiveSheet.Range("$A$1:$W$10000").AutoFilter 10, Criteria1:="=" & dt
ActiveSheet.Range("$A$1:$W$10000").AutoFilter Field:=16, Criteria1:= _
"SW\Finn"
'Name range "userNames"
With ActiveSheet
lRow = .Cells(Rows.Count, 16).End(xlUp).Row
If lRow < 3 Then Exit Sub
.Cells(1, 16).Offset(1, 0).Resize(lRow - 1).SpecialCells(xlCellTypeVisible).Select
End With
Selection.Name = "userNames"
'remove all defined names
On Error Resume Next
ActiveWorkbook.Names("userNames").Delete
'Formate Date back
Range("J:J").Select
Selection.NumberFormat = "yyyy-mm-dd"
End Sub

Answer 1

I had some free time and wrote up an example program that copies 10% of a defined set of rows, and then pastes it into a different sheet. I have added some comments to help explain what each section is achieving.
Sub Example()
'Define the Start and End of the data range
Const STARTROW As Long = 1
Dim LastRow As Long
LastRow = Sheet1.Cells(Sheet1.Rows.Count, 1).End(xlUp).Row
'Create an Array - Length = Number of Rows in the data
Dim RowArr() As Long
ReDim RowArr(STARTROW To LastRow)
'Fill the Array - Each element is a row #
Dim i As Long
For i = LBound(RowArr) To UBound(RowArr)
RowArr(i) = i
Next i
'Shuffle the Row #'s within the Array
Randomize
Dim tmp As Long, RndNum As Long
For i = LBound(RowArr) To UBound(RowArr)
RndNum = WorksheetFunction.Floor((UBound(RowArr) - LBound(RowArr) + 1) * Rnd, 1) + LBound(RowArr)
tmp = RowArr(i)
RowArr(i) = RowArr(RndNum)
RowArr(RndNum) = tmp
Next i
'Calculate the number of rows to divvy up
Const LIMIT As Double = 0.1 '10%
Dim Size As Long
Size = WorksheetFunction.Ceiling((UBound(RowArr) - LBound(RowArr) + 1) * LIMIT, 1)
If Size > UBound(RowArr) Then Size = UBound(RowArr)
'Collect the chosen rows into a range
Dim TargetRows As Range
For i = LBound(RowArr) To LBound(RowArr) + Size
If TargetRows Is Nothing Then
Set TargetRows = Sheet1.Rows(RowArr(i))
Else
Set TargetRows = Union(TargetRows, Sheet1.Rows(RowArr(i)))
End If
Next i
'Define the Output Location
Dim OutPutRange As Range
Set OutPutRange = Sheet2.Cells(1, 1) 'Top Left Corner
'Copy the randomly chosen rows to the output location
TargetRows.Copy Destination:=OutPutRange.Resize(TargetRows.Rows.Count).EntireRow
End Sub