Random Select Rows and Copy to Next Sheet based on user input value

[Sully1440]

Hi All,
I'm having difficulty randomly selecting rows from one sheet and pasting to another. I'd like the user to identify the "Desired # of Questions =" to be copied from Cell F1.
When the user selects the macro, I want it to go through the list on sheet named "Questions" and randomly copy and paste the rows to another sheet names "Survey" until the number of questions equals the number in cell F1.
BUT, I only want to grab the rows where there is a number in Column A (and not the header).

I attached the spreadsheet as an example. Any help would be appreciated.
Thx,
Jim



Option Explicit
Option Base 1

Sub Random_Survey()
Dim LastRow As Long
Dim NbRows As Long
Dim RowList()
Dim i As Long, j As Long, k As Long
Dim RowNb As Long
Sheets("Culture Questions").Activate
LastRow = Range("A" & Rows.Count).End(xlUp).Row
NbRows = IIf(LastRow < 200, LastRow * 0.2, 20)
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("Survey").Cells(k + 2, "A")

k = k + 1
NextStep:
Next i
End Sub

[Paul_Hossler]

1. Added CODE tags to your post (again)

2. try something like this as a start





Option Explicit
Sub Random_Survey()
Dim Q() As Long, RN() As Double
Dim i As Long, j As Long, Q1 As Long, N As Long
Dim RN1 As Double


'load Q
N = 0
With Worksheets("Questions")
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

'check to see if enough questions
If .Range("F2").Value > N Then
MsgBox "not enougth questions"
Exit Sub
End If

'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 = Worksheets("Questions").Range("F2").Value

j = 2
For i = LBound(Q) To N
.Cells(Q(i), 2).Resize(1, 3).Copy Worksheets("Survey").Cells(j, 1)
j = j + 1
Next i

End With

End Sub

[Sully1440]

Thanks Paul. Exactly what I wanted.

Got your note about Code Tags.

Wish I had your skills!!!