How to use VBA to randomly copy rows based on a specified value

[reinemone09]

Hi, I'm working on a project which would randomly select rows (as samples) from sheet "Source" based on the number of sample to take in cell E7 of sheet "Review".
The sheets to be copied are only ones that fits the criteria "Y" in column Q.

Info:
- Cell E7 value = 3
- Amount of rows that match the criteria = 4

I have made the coding to ensure all rows are copied if cell E7 value = number of matches, and to randomly copy the rows if E7 value < number of matches

However, as seen in the uploaded image, Q(N) poses an error subscript out of range. Can you help fix the coding to ensure that E7 value number of rows are randomized and the random rows are copied to the new sheet "PEP"?

This is the VBA code that I have worked on so far:

Dim wsSampling, sh As Worksheet
Dim pep2 As Worksheet

'Set worksheet variables
Set wsSampling = ThisWorkbook.Worksheets("Review")
Set sh = ThisWorkbook.Worksheets("Source")

'Check Cell E7 of sheet "Review"
If wsSampling.Range("E7").Value = O Then
    'Create new sheet with sheet name "PEP"
    Set pep2 = ThisWorkbook.Worksheets.Add(after:=sh)
    pep2.Name = "PEP"
    'Set cell A1 of sheet "PEP" = "NIL"
    pep2.Range("A1").Value = "NIL"
Else
    'Create new sheet with sheet name "PEP"
    Set pep2 = ThisWorkbook.Worksheets.Add(after:=sh)
    pep2.Name = "PEP"
    'Get last row number & filter data
    lastRow1b = sh.Range("Q" & sh.Rows.count).End(xlUp).Row
    sh.Range("A1:AV" & lastRow).AutoFilter field:=17, Criteria1:="Y"
    sh.Rows(1).Copy
    pep2.Rows(1).Insert Shift:=xlDown
    Application.CutCopyMode = False
        
    'Check if number of "Y" values is greater than maximum number of rows to be copied
    Dim visibleCount1b As Long
    visibleCount1b = Application.WorksheetFunction.Subtotal(103, sh.Range("Q2:Q" & lastRow1b))
    
    If visibleCount1b > wsSampling.Range("E7").Value Then
    Set rngRandom1b = sh.Range("A2:AV" & lastRow1b).SpecialCells(xlCellTypeVisible).SpecialCells(xlCellTypeConstants)
    
    'load Q
    N = 0
    With Worksheets("Source")
        For i = 1 To .Cells(1, 1).CurrentRegion.Rows.count
            If IsNumeric(.Cells(i, 1).Value) Then
                If .Cells(i, 1).Value > 0 Then
                    N = N + 1
                    ReDim Preserve Q(1 To N)
                    Q(N) = i
                End If
            End If
        Next i
        
        'add random numbers
        ReDim RN(1 To UBound(Q))
        
        Randomize
        For i = LBound(RN) To UBound(RN)
            RN(i) = 10000# * Rnd
        Next i
        
        For i = LBound(RN) To UBound(RN) - 1
            For j = i + 1 To UBound(RN)
                If RN(i) > RN(j) Then
                    RN1 = RN(i)
                    Q1 = Q(i)
                    RN(i) = RN(j)
                    Q(i) = Q(j)
                    RN(j) = RN1
                    Q(j) = Q1
                End If
            Next j
        Next i
        
        
        N = wsSampling.Range("E7").Value
        
        j = 2
        For i = LBound(Q) To N
            .Range("A" & Q(i) & ":AV" & Q(i)).Copy pep2.Range("A" & j)
            j = j + 1
        Next i
                
    End With
    
    With pep2.Sort
        .SortFields.Clear
        .SortFields.Add Key:=Range("A1"), Order:=xlAscending
        .SetRange Range("A1:AV" & lastRow1b)
        .Header = xlYes
        .Apply
    End With

    Else
        'Copy all visible "Y" values to new worksheet
        Set filterRange = sh.Range("A2:AV" & lastRow1b)
        filterRange.SpecialCells(xlCellTypeVisible).Copy pep2.Range("A2")
        
    End If
    
    'Remove filter from column Q
    sh.Range("Q1:Q" & lastRow1b).AutoFilter
 
End Sub

 

[Legacy 143009]

Try to declare

Dim Q() as Variant

 

[Herakles]

Welcome to Mr Excel reinemone09

I've adapted some code that I had which seems to do what you want.

You will need to make reference to the Microsoft Scripting Runtime library as the code uses a Dictionary
to keep track of the randomly selected row numbers.

Public Sub subCopyRandomRows()
Dim dictRows As New Scripting.Dictionary
Dim rngRows As Range
Dim lngSampleSize As Long
Dim lngRandom As Long
Dim WsSource As Worksheet
Dim WsDestination  As Worksheet

    ActiveWorkbook.Save
    
    Set WsSource = Worksheets("Source")
    
    Set WsDestination = Worksheets("PEP")
    
    lngSampleSize = Worksheets("Review").Range("E7")
    
    Set rngRows = WsSource.Range("A1").CurrentRegion
    
    WsDestination.Cells.Clear
    
    WsSource.Rows(1).Copy Destination:=WsDestination.Range("A1")
            
    Do
        lngRandom = Int((rngRows.Rows.Count - 1 - rngRows.Cells(1).Row + 1) * Rnd + rngRows.Cells(1).Row)
        If WsSource.Cells(lngRandom, 17) = "Y" And Not dictRows.Exists(lngRandom) Then
            dictRows.Add Key:=lngRandom, Item:=lngRandom
            With WsDestination.Range("A" & WsDestination.Rows.Count).End(xlUp)
                WsSource.Rows(lngRandom).Copy Destination:=WsDestination.Range("A" & .Row + 1)
            End With
        End If
    Loop Until WsDestination.Range("A" & WsDestination.Rows.Count).End(xlUp).Row = lngSampleSize + 1
    
    WsDestination.Range("A1").CurrentRegion.EntireColumn.AutoFit
    
    MsgBox lngSampleSize & " rows copied to worksheet '" & WsDestination.Name & "'.", vbInformation, "Confirmation"

End Sub