preventing endless loops

[J_J]

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

 

[Tom Ogilvy]

Why not just put in
=rand()
in D110000, (or to the last row used by column C), then sort the two
columns on the random number, then take the top N values.

 

[J_J]

Thanks Tom,
Yes I prefer that, but still wish to know how to overcome the problem in
VBA...
J_J

 

[Tom Ogilvy]

It worked fine for me with 7000 items, so your premise is flawed. I suspect
you will have problems if you have fewer items than you need to select (in
your sample, 5000).

 

[J_J]

In order to prevent Excel from beeing locked because of too many items (or
maybe some blank items) Can we not add a control loop to CallMeNot process
so that if less then 10000 items are found it will skip the selection
process and jump to finish the code?.
J_J

 

[J_J]

Sorry with my mistake
It should have been
DontCallMe:

 

[Tom Ogilvy]

If WorksheetFunction.CountA(objRangeA) < 10000 Then
MsgBox "Missing items from " & objRangeA.Parent.Name & " ", _
vbExclamation, " Maks10000"
GoTo DontCallMe
End If
does that in RAST. Just use similar code in the command button click
event.

--

Regards,
Tom Ogilvy