Random Sort (Can anybody Handle it)

[darno]

Hi there,


Can any body help me in creating a macro that could select 20 row
randomly from a list of 200 rows and copy those to sheet2, but th
copied rows must not be repeated and must be 20. for example

COLUMN A COLUMN B
1 cat
2 dog
3 cup
4 hat
5 chair

Now on the basis of above data the program should select both th
columns A and B and give them a random sort and select 3 differen
records and paste those to sheet2, For example the desired result ma
be:

1 cat
5 chair
3 cup


Regards,



Darn

 

[keepITcool]

Darno,
does this give you a start ?
i use the collection's key to ensure uniqueness

Sub ExtractRandom20()
Dim tmp As Collection
Dim rngSrc As Range
Dim rngTgt As Range
Dim r&


Set rngSrc = Worksheets(1).Range("a1:a200")
Set rngTgt = Worksheets(2).Range("a1:a20")

If rngTgt.Rows.Count > 0.5 * rngSrc.Rows.Count Then
MsgBox "Make target range smaller"
Exit Sub
End If

Randomize

Set tmp = New Collection
On Error Resume Next
With rngSrc
While tmp.Count < rngTgt.Rows.Count
r = Int(Rnd * .Rows.Count + 1)
tmp.Add .Cells(r, 1).Value, CStr(r)
Wend
End With

For r = 1 To tmp.Count
rngTgt(r, 1) = tmp(r)
Next

End Sub



keepITcool

< email : keepitcool chello nl (with @ and .) >
< homepage: http://members.chello.nl/keepitcool >

 

[sulprobil]

'*******************************************************
**
'Purpose: produce n unique random ints within 1..m, m

= n

'Inputs: mRange - highest possible random number in
1..m
' Implicitly: Length of Application.Caller Range
' (count of requested random numbers)
'Returns: array of unique random integers
'*******************************************************
**
Public Function UniqRandInt(ByVal mRange As Long) As
Variant
'returns n unique random ints within 1..m >= n
'Orig: J.E. McGimpsey
http://www.mcgimpsey.com/excel/randint.html
'Changed by: sulprobil http://Reverse
("moc.liborplus.www")
Dim vArr As Variant
Dim vResult As Variant
Dim nCount As Long
Dim nRand As Long
Dim i As Long
Dim j As Long

Application.Volatile
If TypeName(Application.Caller) <> "Range" Then Exit
Function
With Application.Caller
ReDim vResult(1 To .Rows.Count, 1
To .Columns.Count)
nCount = .Count
If nCount > mRange Then
RandInt = CVErr(xlErrNum)
Exit Function
ElseIf nCount = 1 Then
UniqRandInt = CLng((mRange - 1) * Rnd() + 1)
Exit Function
End If
End With
ReDim vArr(1 To mRange)
For i = 1 To mRange
vArr(i) = i
Next i
nCount = 1
For i = 1 To UBound(vResult, 1)
For j = 1 To UBound(vResult, 2)
nRand = Int(((mRange - nCount + 1) * Rnd) + 1)
vResult(i, j) = vArr(nRand)
vArr(nRand) = vArr(mRange - nCount + 1)
nCount = nCount + 1
Next j
Next i
UniqRandInt = vResult
End Function