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

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

If possible, start by adding a `=RAND()` in your sheet on every row and then sort by that column. That will give you a simpler selection method. — Sam, Aug 31 '21 at 16:11
Defined names are used for something different. Instead, you should use variables to create a reference to a range: `Dim rg As Range: Set rg = ActiveSheet.Cells(1, 16).Offset(1, 0).Resize(lRow - 1).SpecialCells(xlCellTypeVisible)`. Now you could do `Dim cCount As Long: cCount = Int(rg.Cells.Count / 10): If rg.Cells.count Mod 10 > 0 Then cCount = cCount + 1` . Now you could continue using the function [here](https://stackoverflow.com/questions/18543169/unique-random-numbers-using-vba/18543399#18543399) to solve the 'random business'. Learn how to avoid `Select` and any flavor of `Active`... — VBasic2008, Aug 31 '21 at 17:41
As mentioned by VBasic2008, please read this [answer](https://stackoverflow.com/a/10717999/15597936) on how to avoid using `Select`. — Raymond Wu, Sep 01 '21 at 01:35

Toddleson · Answer 1 · 2021-08-31T21:36:12.853

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

I'm not much of a mathematician, so I have no idea if my Random Number Shuffle is biased or not. But it appeared sufficiently random in my brief testing. — Toddleson, Aug 31 '21 at 21:33

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

1 Answers1