Random selection modification not working

[Damian37]

Hello all,
I'm trying to modify a random selection code I have. I'm trying to retrieve 5% of the total number of records in the raw data. I'm currently receiving a run-time error when I try to run it. I'm not entirely sure why it's not working. I commented out the portion of my code that filters on current month, and I tried to change the autofilter values, but not entirely sure what I should place after the autofilter in the code. This is the code I have:

Option Explicit
Sub Filter_Data()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("CMOR_XSAR_QA_Data")
    Set ws2 = Worksheets("Random Selection")
   
    'Filter & copy current month records
'    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
'    With ws1.Range("A1").CurrentRegion
'        .AutoFilter
'        If .SpecialCells(xlCellTypeVisible).Address <> .Rows(1).Address Then
'            ws2.Range("A1").CurrentRegion.Offset(1).ClearContents
'            .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Range("A2")
'        Else
'            MsgBox "No records found for the current month"
'            .AutoFilter
'            Exit Sub
'        End If
'        .AutoFilter
'    End With
   
    'Randomise the records & show 10% only
    Dim LRow As Long, LCol As Long, i As Long
    LRow = ws2.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws2.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    With ws2
        With .Range(.Cells(2, LCol), .Cells(LRow, LCol))
            .Formula = "=Rand()"
        End With
        .Range("A1").CurrentRegion.Sort key1:=ws2.Cells(2, LCol), order1:=xlAscending, Header:=xlYes
        .Columns(LCol).ClearContents
        .Rows(Int((LRow - 1) / 5) + 3 & ":" & LRow).Delete
    End With
End Sub

This is the line that is being highlighted after I receive the run-time error:

.Range("A1").CurrentRegion.Sort key1:=ws2.Cells(2, LCol), order1:=xlAscending, Header:=xlYes

Any help is greatly appreciated. Thank you.

D.

 

[Damian37]

Hey all,
I modified the code some more, and I'm no longer receiving any errors, butI'm also not receiving any results.

Option Explicit
Sub Filter_Data()
    Dim ws1 As Worksheet, ws2 As Worksheet
    Set ws1 = Worksheets("CMOR_XSAR_QA_Data")
    Set ws2 = Worksheets("Random Selection")
    
    'Filter & copy current month records
    If ws1.AutoFilterMode Then ws1.AutoFilter.ShowAllData
    With ws1.Range("A1")
        .AutoFilter
        If .SpecialCells(xlCellTypeVisible).Address <> .Rows(1).Address Then
            ws2.Range("A1").ActiveWorksheet.Offset(1).ClearContents
            .Offset(1).Resize(.Rows.Count - 1).Copy ws2.Range("A2")
        Else
            'MsgBox "No records found for the current month"
            .AutoFilter
            Exit Sub
        End If
        .AutoFilter
    End With
    
    'Randomise the records & show 5% only
    Dim LRow As Long, LCol As Long, i As Long
    LRow = ws2.Cells.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
    LCol = ws2.Cells.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column + 1
    With ws2
        With .Range(.Cells(2, LCol), .Cells(LRow, LCol))
            .Formula = "=Rand()"
        End With
        .Range("A1").CurrentRegion.Sort key1:=ws2.Cells(2, LCol), order1:=xlAscending, Header:=xlYes
        .Columns(LCol).ClearContents
        .Rows(Int((LRow - 1) / 5) + 3 & ":" & LRow).Delete
    End With
End Sub

Thoughts?

Thanks,
D.

 

[Damian37]

Hello All,
Okay, I've decided to use an entirely different approach to randomly select 5% of the records within the raw data. However, my headers aren't being copied over to the new worksheet. Here's the new code I'm using:

Sub Example()
    
    Const STARTROW As Long = 1
    Dim LastRow As Long
    Dim ws1 As Worksheet, ws2 As Worksheet
    Dim rngSource As Range
    Dim rngDestination As Range
    Dim Head As Variant
    Set ws1 = Worksheets("CMOR_XSAR_QA_Data")
    Set ws2 = Worksheets("Random Selection")
    LastRow = ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    
    
    With ws1
     Head = .Range(.Cells(1, 1), .Cells(1, Columns.Count).End(xlToLeft))
    End With
    
    Set rngDestination = ws2.Cells(1, Columns.Count).End(xlToLeft).Offset(0, 1)
    
    rngDestination.Resize(1, UBound(Head, 2)) = Head
    
    
    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.05 '5%
    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 = ws1.Rows(RowArr(i))
        Else
            Set TargetRows = Union(TargetRows, ws1.Rows(RowArr(i)))
        End If
    Next i
    
    
    Dim OutPutRange As Range
    Set OutPutRange = ws2.Cells(1, 1)
    
    
    TargetRows.Copy Destination:=OutPutRange.Resize(TargetRows.Rows.Count).EntireRow
    
End Sub

Can anyone tell me what I'm doing wrong? I'm getting my random data, but I'm not getting my headers to copy over.

D.