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

reinemone09

New Member
Joined
Apr 28, 2023
Messages
1
Office Version
  1. 2016
Platform
  1. Windows
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:

VBA Code:
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
 

Attachments

  • forum.PNG
    forum.PNG
    8.1 KB · Views: 12

Excel Facts

Return population for a City
If you have a list of cities in A2:A100, use Data, Geography. Then =A2.Population and copy down.
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.

1682677001350.png

VBA Code:
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
 
Upvote 0

Forum statistics

Threads
1,213,539
Messages
6,114,221
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top