Hi,
The below code manages to pick 5000 random items out of 10000 from Sheet1
columnA and display them on Sheet2. But the program locks if there are not
10000 data written in Sheet1 columnA.
Hope I need not have to enter that much data just to try it functions as it
should...
Help will be appreciated.
Regards
J_J


'----------------------------------------------
Sub Rast()
Dim RS As Long
Dim objRangeA As Range
Dim objRangeB As Range
Dim objRangeC As Range
Dim blnNotThere As Boolean

Set objRangeA = Worksheets(1).Range("A1:A10000")
Set objRangeB = Worksheets(2).Range("B1:B10000")
Set objRangeC = Worksheets(2).Range("C1:C10000")

'
If WorksheetFunction.CountA(objRangeA) < 10000 Then
MsgBox "Missing items from " & objRangeA.Parent.Name & " ", _
vbExclamation, " Maks10000"
GoTo DontCallMe
End If

Worksheets(2).Select
StartOver:

If WorksheetFunction.CountA(objRangeC) = 0 Then
objRangeC.Value = objRangeA.Value
objRangeC.Columns.AutoFit
objRangeB.ClearContents
objRangeB.ColumnWidth = objRangeC.ColumnWidth
'Range("A1").ClearContents
Range("A1").ColumnWidth = objRangeC.ColumnWidth
GoTo DontCallMe
End If

Do While blnNotThere = False
Randomize
RS = Int(Rnd * 10000 + 1)

If Not IsError(Application.Match(objRangeC(RS), objRangeC, 0)) Then
blnNotThere = True
Range("A1").Value = objRangeC(RS)
objRangeB(WorksheetFunction.CountA(objRangeB) + 1).Value =
objRangeC(RS)
objRangeC(Application.Match(objRangeC(RS), objRangeC, 0)).Delete
shift:=xlUp
End If
Loop


If WorksheetFunction.CountA(objRangeC) = 0 Then
If MsgBox("OK? ", vbQuestion + vbYesNo, _
" Randomly") = vbYes Then GoTo StartOver
End If

DontCallMe:
Set objRangeA = Nothing
Set objRangeB = Nothing
Set objRangeC = Nothing
End Sub

Private Sub CommandButton1_Click()
For z = 1 To 5001
Rast
Next z
End Sub