Randomly select 25% of list and copy to new tab

Hi fatboyzfishing,

Welcome to the forum!!

Let me know how this goes:

Option Explicit
Sub Macro1()

    Dim ws As Worksheet
    Dim lngEndRow As Long
    Dim lngLoopCount As Long
    Dim objRowNumbers As Object
    Dim lngMyRow As Long
    
    Application.ScreenUpdating = False
    
    Set ws = Worksheets("Key List")
    lngEndRow = ws.Cells(Rows.Count, "A").End(xlUp).Row 'Sets the 'lngEndRow' variable from Col. A of the ws tab. Change to suit.
    Set objRowNumbers = CreateObject("Scripting.Dictionary")
    
    Randomize 'Without this the output will be the same
    
    Do Until lngLoopCount = Int(lngEndRow / 4) 'Rounds down to the nearest integer ie for 26 items it will run 6 times.
    
        lngMyRow = Rnd * (lngEndRow - 1) + 1
        If lngMyRow > 0 Then
            If objRowNumbers.Exists(CStr(lngMyRow)) = False Then
                If InStr(ws.Name, " ") > 0 Then 'Tabs with a space(s) need to be incased within single quotes
                    With Sheets("Random List").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                        .Formula = "='" & CStr(ws.Name) & "'!A" & lngMyRow
                        .Value = .Value 'Converts the formula from the line above to a value. Comment out to leave original formula as is.
                    End With
                Else
                    With Sheets("Random List").Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
                        .Formula = "=" & CStr(ws.Name) & "!A" & lngMyRow
                        .Value = .Value 'Converts the formula from the line above to a value. Comment out to leave original formula as is.
                    End With
                End If
                objRowNumbers.Add CStr(lngMyRow), lngLoopCount
                lngLoopCount = lngLoopCount + 1
            End If
        End If
        
    Loop
    
    Set ws = Nothing
    Set objRowNumbers = Nothing
    
    Application.ScreenUpdating = True

End Sub

Regards,

Robert

Try running this:

Sub RandomPull2()
    Dim r As Range
    Dim rs As Long, r2 As Double, c As Long, max As Long
    
    Set r = Worksheets("Key List").Range("Table5[Key]")
    max = r.rows.Count
    rs = CLng(max / 100 * 25) 'percentage - adjust accordingly
    
    c = 0
    Randomize
    With CreateObject("scripting.dictionary")
        Do While c < rs
            r2 = Rnd
            r2 = (r2 * 1000000) - ((max - 1) * Int((r2 * 1000000) / (max - 1))) + 1
            Do While .Exists(r(r2).Value)
                r2 = Rnd
                r2 = (r2 * 1000000) - ((max - 1) * Int((r2 * 1000000) / (max - 1))) + 1
            Loop
            .Add r(r2).Value, 1
            c = c + 1
        Loop
        Worksheets("Random List").Range("A1").Resize(.Count) = Application.Transpose(.keys)
    End With
    Set r = Nothing
End Sub

You're welcome