VBA Randomly Select and Put on Sheet2

[Stephen_IV]

Good afternoon,
I have code below that will move the entirerow to Sheet2 if column A has an x in it. I am looking to adapt this code so that I could randomly select 96 people with out having an x in Column A. Any help will be greatly appreciated! Thanks in advance Stephen!

Sub moveit()
Dim r As Range
Set r = Range("a1:a3000")

For Each cell In r
    If cell.Value = "x" Then
        cell.EntireRow.Copy Sheets("sheet2").Range("a65536").End(xlUp)(2, 1)
    End If
Next
End Sub

 

[hallingh]

How about something like this?

Sub moveit()
Dim r As Range
Dim x As Long
Dim y As Long
Set r = Range("a1:a3000")
x = 1
Do While x < 97
For Each cell In r
    y = (Rnd * 3000)
    If cell.Row = y Then
        cell.EntireRow.Copy Sheets("sheet2").Range("a65536").End(xlUp)(2, 1)
    x = x + 1
    End If
Next
Loop
End Sub

This isn't tested at all, so really just kinda a stab in the dark. Hope this helps.

Hank

 

[hallingh]

Come to think of it, this sub will probably take a really long long time to execute. But I think using the Rnd function could be a way to do this. You could just make the random number from 1 to 10 and then just see if its equal to a constant to decide whether to copy it or not. Still random, but won't take nearly as long.

Hank

 

[Stephen_IV]

Thanks hallingh for trying but when I change specifications like I need 100 rows moved to Sheet2 the Do While x < 101 section seems to alternating sometimes 92 sometimes 97 etc. Is there a way to keep the 100 constant. in other words make sure that as in the first example that I get exactly 96 or in this example a 100. Thaks in advance Stephen

Sub Moveit()
Dim r As Range
Dim x As Long
Dim y As Long
Set r = Range("a1:a1683")
x = 1
Do While x < 101
For Each cell In r
    y = (Rnd * 1683)
    If cell.Row = y Then
        cell.EntireRow.Copy Sheets("sheet2").Range("a65536").End(xlUp)(2, 1)
    x = x + 1
    End If
Next
Loop
End Sub

 

[hallingh]

Hmmmmm I can't see of the top of my head why this isn't working. I have to take off, but if noone else has helped you out on this one by tomorrow morning I'll see if I can fix it.

Good luck.

Hank

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG24May39
[COLOR="Navy"]Dim[/COLOR] gNum [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] R [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] rw [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Integer[/COLOR]
[COLOR="Navy"]Set[/COLOR] R = Range("a1:a1683")
[COLOR="Navy"]Dim[/COLOR] cell [COLOR="Navy"]As[/COLOR] Range
Randomize
gNum = Application.InputBox(prompt:="Please Enter Number ", Title:="Copy Rnd Rows", Type:=1)
[COLOR="Navy"]If[/COLOR] gNum = 0 [COLOR="Navy"]Then[/COLOR] [COLOR="Navy"]Exit[/COLOR] [COLOR="Navy"]Sub[/COLOR]
 [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
        [COLOR="Navy"]Do[/COLOR] Until .Count = gNum
         rw = Int(Rnd * R.Count) + 1
         [COLOR="Navy"]If[/COLOR] Not .Exists(rw) [COLOR="Navy"]Then[/COLOR]
            .Add rw, ""
            [COLOR="Navy"]If[/COLOR] Rng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Rng = Range("A" & rw)
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Rng = Union(Rng, Range("A" & rw))
            [COLOR="Navy"]End[/COLOR] If
         [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Loop[/COLOR]
[COLOR="Navy"]End[/COLOR] With
Rng.Copy Sheets("sheet36").Range("a65536").End(xlUp)(2, 1)
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Stephen_IV]

Thanks for your response Mick,

The code is only pulling column A but I have 28 Columns in the row. By any chance can we get the code to pull the entire row?

Thanks again Stephen!

 

[MickG]

Alter last line as below.

Rng.EntireRow.Copy Sheets("sheet2").Range("a65536").End(xlUp)(2, 1)

Mick

 

[Stephen_IV]

Thanks Mick,

That did the trick!