• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

Run-time error '9' Subscript out of Range

Damian48

New Member
Hello,
I'm attempting to run a macro that will filter data in a worksheet, create a new sheet, copy random rows copy and paste the rows selected to the new sheet. My filter Sub is functioning fine, my create a new sheet Sub is also working just fine. However, when I attempt the run the Sub to randomly selet rows, copy, and paste the data to the new sheet I receive the Run-time error. I've looked over my code and it appears to be right, so I'm not sure what is creating the error. I've seen the line of code creating the error, and it's indicating the end of the line is where the error lies. I was hoping someone might be able to help me with this. My ActiveSheet is the sheet where the data is located. The line of code creating the error is: Set TargetRows = Union(TargetRows, ActiveSheet.Rows(RowArr(i))). The bold portion of the line is where the error lies. I've added the entire code below.
Code:
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 Row_Selection()
    'Define the Start and End of the data range
    Const STARTROW As Long = 1
    Dim LastRow As Long
    LastRow = ActiveSheet.Cells(ActiveSheet.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 UBound(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
    
    'Define the Output Location
    Dim OutPutRange As Range
    Set OutPutRange = Sheet1.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

Any help anyone can offer me would be greatly appreciated. Thank you.

D.
 
Hello All,
I changed my code around and I now have it working to paste the random selections into a new worksheet. However, I would like to adjust the code to account for any new sheet name (i.e., Sheet1, Sheet2, or Sheet3). I would prefer to have a generic value so I don't have to use an exact name for the new sheet, because if the user needed to run the macro more than once, new sheets will be made with different names. I've included the code below:
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)


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
Right now, the user will only be able to run the macro once when the new sheet name is "Sheet1", if for any reason, the user were to need to run the macro more than once, the macro will fail, because the new sheet created will no longer be named "Sheet1". I've also created a sheet named Macro buttons. When I click the button I created to run the macro, the sheet the button is in adds filters to the first row, and appears to hide the first 4 rows in the "Macro Buttons" Sheet. Any idea why this might be happening? Any help will be greatly appreciated. Thank you.

D.
 
Last edited:
Back
Top