Selecting rows randomly in Excel

[Damian37]

I'm trying to select random rows within my Active Worksheet filtered data, copy the rows, and have them pasted within another sheet in the workbook. I'm trying to use this code, however I keep getting an error on the Else statement for the TargetRows. Here's the code:

Sub Row_Selection()

    Const STARTROW As Long = 1

    Dim LastRow As Long

    LastRow = ActiveSheet.Cells(ActiveSheet.Rows.Count, 1).End(xlUp).Row

  
    Dim RowArr() As Long

    ReDim RowArr(STARTROW To LastRow)

  
    Dim i As Long

    For i = LBound(RowArr) To UBound(RowArr)

        RowArr(i) = i

    Next i

  
    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

    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)

  
    Dim TargetRows As Range

    For i = LBound(RowArr) To LBound(RowArr) + Size

        If TargetRows Is Nothing Then

            Set TargetRows = ActiveSheet.Rows(RowArr(i))

        Else

            Set TargetRows = Union(TargetRows, ActiveSheet.Rows(RowArr(i)))

        End If

    Next i


    Dim OutPutRange As Range

    Set OutPutRange = Sheet1.Cells(1, 1) 'Top Left Corner

  
    TargetRows.Copy Destination:=OutPutRange.Resize(TargetRows.Rows.Count).EntireRow

  

End Sub

I'm unsure where the hiccup is. The code breaks at the TargetRows section of the code. Thank you in advance.

D.

 

[Damian37]

Hello all,
So I was able to find coding that does what I need it to. It's filtering the file for current month data, randomly copy 10% of the records available and paste the values into the new sheet that was created. However, I have two questions:
1. How can I also copy over the column names to the new sheet?
2. How can I rename the new sheet within the VBA code to something like: "Random Population". I've inserted the code below:

Sub Filter_by_month()
'
' Filter_by_month Macro
    ActiveSheet.Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterThisMonth, _
    Operator:=xlFilterDynamic
End Sub
Sub AddSheets()
Sheets.Add After:=Sheets(Sheets.Count)
End Sub
Sub TakeSample()
Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, J As Long, k As Long
Dim RowNb As Long
Dim s As String
Sheets("FILENAME").Activate


Application.ScreenUpdating = False
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    s = i & ":" & i
    If IsEmpty(Cells(i, 1).Value) Then
         Rows(s).EntireRow.Hidden = True
    End If
Next
Application.ScreenUpdating = True
    
    
    Sheets("FILENAME").Activate
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = LastRow * 0.1
    'NbRows = IIf(LastRow < 200, LastRow * 0.1, 10)
    ReDim RowList(1 To NbRows)
    k = 1
    For i = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To k
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(k) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet1").Cells(k, "A")
        k = k + 1
NextStep:
    Next i
End Sub

As always, any and all help is greatly appreciated. Thank you in advance.

D.

 

[Damian37]

I did a test with some example data.
If you could share your file on google drive, maybe someone can download the file and check what the problem is.
If you have confidential data in your file you can replace it with generic data.
Remember to share your file, copy the link and paste here.

Hi Dante,
I've changed my code around, and now it appears to be working. However, I've discovered a couple of issues. If the macro were to be run more than once, it will fail, because the new sheet that will be created will no longer be sheet1 unless the user closes out of the file without saving and run the macro again once they've reopened the file.
Current issues:
1. If macro is run more than once, it will fail, because the new sheet created will not be named "Sheet1".
2. When I click on the button I've assigned the macro to, the sheet the button is located on has filters added to the columns and hides the first four rows. Not sure why this is happening when I run the query through the button.

I've included the updated code below:

Sub Filter_by_month()
'
' Filter_by_month Macro
    ActiveSheet.Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterThisMonth, _
    Operator:=xlFilterDynamic


Sheets.Add After:=Sheets(Sheets.Count)


Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, J As Long, k As Long
Dim RowNb As Long
Dim s As String
Sheets("FILENAME").Activate


Application.ScreenUpdating = False
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    s = i & ":" & i
    If IsEmpty(Cells(i, 1).Value) Then
         Rows(s).EntireRow.Hidden = True
    End If
Next
Application.ScreenUpdating = True
    
    
    Sheets("FILENAME").Activate
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = LastRow * 0.1
    'NbRows = IIf(LastRow < 200, LastRow * 0.1, 10)
    ReDim RowList(1 To NbRows)
    k = 1
    For i = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To k
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(k) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet1").Cells(k, "A")
        k = k + 1
NextStep:
    Next i
End Sub

Any help is greatly appreciated. Thank you.

D.

 

[rlv01]

So I'm still receiving this error

Consider adding some temporary debug code to help you understand what is happening.
(not tested)

    Dim TargetRows As Range
    Dim DebugMsg As String, DebugRange As Range
    For i = LBound(RowArr) To LBound(RowArr) + Size
        If TargetRows Is Nothing Then
            Set TargetRows = ActiveSheet.Rows(RowArr(i))
        Else
            On Error Resume Next
            Set DebugRange = ActiveSheet.Rows(RowArr(i))
            On Error GoTo 0
            
            If DebugRange Is Nothing Then
                DebugMsg = "ActiveSheet.Rows(RowArr(" & i & ")) is not a valid range" & vbCr
                DebugMsg = DebugMsg & "i = " & i & vbCr
                DebugMsg = DebugMsg & "TargetRows: " & TargetRows.Address(, , , 1) & vbCr
                DebugMsg = DebugMsg & "Size  = " & Size & vbCr
                DebugMsg = DebugMsg & "LBound/Ubound: " & LBound(RowArr) & "/" & UBound(RowArr) & vbCr
                MsgBox DebugMsg
                Exit Sub
            End If
            
            Set TargetRows = Union(TargetRows, ActiveSheet.Rows(RowArr(i)))
        End If
    Next i

 

[DanteAmor]

Current issues:
1. If macro is run more than once, it will fail, because the new sheet created will not be named "Sheet1".
2. When I click on the button I've assigned the macro to, the sheet the button is located on has filters added to the columns and hides the first four rows. Not sure why this is happening when I run the query through the button.

Change this part of your code:

Sub Filter_by_month()
'
' Filter_by_month Macro
    ActiveSheet.Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterThisMonth, _
    Operator:=xlFilterDynamic


Sheets.Add After:=Sheets(Sheets.Count)

For this:

Sub Filter_by_month()
'
' Filter_by_month Macro
  If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
  ActiveSheet.Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterThisMonth, _
  Operator:=xlFilterDynamic

  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("Sheet1").Delete
  On Error GoTo 0
  Sheets.Add After:=Sheets(Sheets.Count)
  ActiveSheet.Name = "Sheet1"

I hope that resolves your issues.

 

[Damian37]

Change this part of your code:

Sub Filter_by_month()
'
' Filter_by_month Macro
    ActiveSheet.Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterThisMonth, _
    Operator:=xlFilterDynamic


Sheets.Add After:=Sheets(Sheets.Count)

For this:

Sub Filter_by_month()
'
' Filter_by_month Macro
  If ActiveSheet.AutoFilterMode Then ActiveSheet.AutoFilterMode = False
  ActiveSheet.Range("A:M").AutoFilter Field:=7, Criteria1:=xlFilterThisMonth, _
  Operator:=xlFilterDynamic

  Application.DisplayAlerts = False
  On Error Resume Next
  Sheets("Sheet1").Delete
  On Error GoTo 0
  Sheets.Add After:=Sheets(Sheets.Count)
  ActiveSheet.Name = "Sheet1"

I hope that resolves your issues.

Thank you so much for this DanteAmor. I did manage to get my code to work. I went back at the reques and I only need to run this macro for the previous month. I've updated the code for the previous month, however, I'm now receiving a "Run-time error '9': Subscript out of range". The line of code that gets highlighted when I click on debug is: "If (RowList(J) = RowNb) Then GoTo NextStep" The code was working when the previous month was November, but for some reason when I attempt to run the code for October, this error pops up. I've entered the code below:

Sub Copy()
Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, J As Long, k As Long
Dim RowNb As Long
Dim s As String
Sheets("FILENAME").Activate


Application.ScreenUpdating = False
For i = 1 To Range("A" & Rows.Count).End(xlUp).Row
    s = i & ":" & i
    If IsEmpty(Cells(i, 1).Value) Then
         Rows(s).EntireRow.Hidden = False
    End If
Next
Application.ScreenUpdating = True
    
    
    Sheets("FILENAME").Activate
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    NbRows = LastRow * 0.1
    'NbRows = IIf(LastRow < 200, LastRow * 0.1, 10)
    ReDim RowList(1 To NbRows)
    k = 2
    For i = 1 To NbRows
        RowNb = Rnd() * LastRow
        For J = 1 To k
            If (RowList(J) = RowNb) Then GoTo NextStep
        Next J
        RowList(k) = RowNb
        Rows(RowNb).Copy Destination:=Sheets("Sheet1").Cells(k, "A")
        k = k + 1
NextStep:
    Next i
End Sub

Any idea why this might be happening? Any help you can give me would be very much appreciated Dante. Thank you.

D.

 

[DanteAmor]

Your macro has several problems, you also asked for an adaptation to run the macro several times and I don't see that you have put it in.

So, I recommend you a macro that I already developed, similar to what you need and works,

Copy x number of random rows from filtered range

Hi Guys, I'm trying to find a way using VBA to copy a specified number of random rows from a filtered range. I've scrambled this together so far LastNumber = WorksheetFunction.Subtotal(103, wb.Sheets(2).Range("A2:A5000")) NumberToImport = ComboRecords.Value MaxNumber = LastNumber -...

www.mrexcel.com

Regards
Dante Amor

 

[Damian37]

Your macro has several problems, you also asked for an adaptation to run the macro several times and I don't see that you have put it in.

So, I recommend you a macro that I already developed, similar to what you need and works,

Copy x number of random rows from filtered range

Hi Guys, I'm trying to find a way using VBA to copy a specified number of random rows from a filtered range. I've scrambled this together so far LastNumber = WorksheetFunction.Subtotal(103, wb.Sheets(2).Range("A2:A5000")) NumberToImport = ComboRecords.Value MaxNumber = LastNumber -...

www.mrexcel.com

Regards
Dante Amor

Thank you Dante. I've adjusted my code to reflect what you provided and it's working perfectly! Thank you.

D.