Random selection

  • Thread starter Thread starter Marco Rod
  • Start date Start date
M

Marco Rod

Hi,

I need your help to find a solution for the following issue:
I have a file with a list of cards in column B. I need a macro to select
randomly 5% of the cards and copy it in column D.

Is possible to do this?

Thanks for your attention
 
Hi,

The issue; if there is one, will be calculating 5% of the cards. This simply
counts the cards (Assuming you start in row 1 of column B) and gets an
approximate 5% of them which may be an exact 5%.

I you dont start on Row 1 change this line

NumCards = Int(LastRow * 0.05)

For example if you start on row 2 use this

NumCards = Int((LastRow-1) * 0.05)

Sub Rnd_Cards()
Dim FillRange As Range
Dim NumCards As Long, LastRow As Long
Set sht = Sheets("Sheet1")' Change to suit
Range("D:D").ClearContents
LastRow = sht.Cells(Cells.Rows.Count, "B").End(xlUp).Row
NumCards = Int(LastRow * 0.05)
Set FillRange = sht.Range("D1:D" & NumCards)
For Each c In FillRange
Do
RndCard = Int((LastRow * Rnd) + 1)
c.Value = sht.Range("B" & RndCard).Value
Loop Until WorksheetFunction.CountIf(FillRange, c.Value) < 2
Next
End Sub
--
Mike

When competing hypotheses are otherwise equal, adopt the hypothesis that
introduces the fewest assumptions while still sufficiently answering the
question.
 
Try;

Sub Rand3Cards()
Dim lRow As Long, lLoop As Long

For lLoop = 1 To 3
lRow = Int((52 * Rnd) + 1)
Cells(lRow, "B").Copy _
Cells(Rows.Count, "D").End(xlUp)(2, 1)
Next lLoop

End Sub
 
Hello,

Thnaks a lot to everybody.

I tried the several solutions and all work perfectly. It will help me a lot.

Thanks again
Marco Rod

"Bernd P" escreveu:
 
Hello Marco,

Assuming that you speak about a 52 card deck, 5% would be 2.6 cards to be
copied.
Should it be 2 cards or 3?

Depending on your decision one could cast a set of dice that show from :1
to 52, two or three times.
The code would say:

for i=1 to 2 (or 3?)
Randomize
staticRnd= Rnd
cardNo = Int(52*Rnd())+1
' copy card number: cardNo into column D
'etc.

next i


Best Regards,


Gabor Sebo

----- Original Message -----
From: "Marco Rod" <[email protected]>
Newsgroups: microsoft.public.excel.programming
Sent: Saturday, April 10, 2010 12:03 PM
Subject: Random selection
 
Hello Marco,

There is a small chance that two or three random numbers will contain a
duplicate.
To guard against this one could set up an array(52) that contains numbers 1
2 3 ......52.
The first time a random number comes up with an answer say: cardNo1: 18 one
should set array(18) to zero.
The second random number: cardNo2 should be selected from 51 candidates (not
52) and the array member that is the cardNo2.th non zero number should be
the outcome. The cardNo2 th array element shall be equated to:0, etc.


Drop me a note should you require further assitance.

Best Regards,


Gabor Sebo
 
Hi
It help me and improved what I built. Thanks for your support.

Thanks a lot Marco Rod

"helene and gabor" escreveu:
 
If the "cards" are a deck of playing cards, then I think you will find the
second method below useful (you won't need the cards on your worksheet as
the subroutine will handle everything. If they are not a deck of cards, then
the first method should be of some help to you.

From a previous post of mine...

Below is a routine I developed quite awhile ago for the compiled VB world,
but the code works fine in Excel's VBA. Two methods are provided... the
first method answer the question you asked but, given you want to generate
cards, you may the second method more to your liking.

FIRST METHOD
=================
The following is a generalized "shuffling" routine. Give it an array of
elements and it will put them in random order and return the randomized
elements back in the original array that was passed to it. It only visits
*each* array element *once* so it is quick. The code takes care of running
the Randomize statement one time only (which is all that is necessary).

Sub RandomizeArray(ArrayIn As Variant)
Dim X As Long
Dim RandomIndex As Long
Dim TempElement As Variant
Static RanBefore As Boolean
If Not RanBefore Then
RanBefore = True
Randomize
End If
If VarType(ArrayIn) >= vbArray Then
For X = UBound(ArrayIn) To LBound(ArrayIn) Step -1
RandomIndex = Int((X - LBound(ArrayIn) + 1) * _
Rnd + LBound(ArrayIn))
TempElement = ArrayIn(RandomIndex)
ArrayIn(RandomIndex) = ArrayIn(X)
ArrayIn(X) = TempElement
Next
Else
'The passed argument was not an array
'Put error handler here, such as . . .
Beep
End If
End Sub

The passed array may be of any normal type -- integer, string, single, etc.
The neat thing is, if you pass an already randomized array to this routine,
those randomly ordered elements will be randomize -- sort of like shuffling
an already shuffled deck of cards. In your case, simply set up the array
something like this

Dim DeckOfCards(1 To 52) As Long
For X = 1 To 52
DeckOfCards(X) = X
Next

and to shuffle (randomize) it, simply call

RandomizeArray DeckOfCards

Each array element will now hold a unique, random number from 1 through 52
for the above example.


SECOND METHOD
=================
Here is another take on the same routine which actually returns "named"
cards such as 3 of Hearts (here your DeckOfCards is declared as a String:

Sub ShuffleDeck(Deck() As String)
Dim X As Integer
Dim TempInt As Integer
Dim TempCard As String
Static TempDeck(1 To 52) As String
Static RanBefore As Boolean
If Not RanBefore Then
RanBefore = True
Randomize
If UBound(Deck) <> 52 Then
'Programmer passed an improper array
MsgBox "Deck array is dimensioned incorrectly"
Exit Sub
ElseIf TempDeck(52) = "" Then
'Initialize the deck of cards
For X = 1 To 52
If ((X - 1) Mod 13) = 0 Then
TempDeck(X) = "Ace"
ElseIf ((X - 1) Mod 13) = 10 Then
TempDeck(X) = "Jack"
ElseIf ((X - 1) Mod 13) = 11 Then
TempDeck(X) = "Queen"
ElseIf ((X - 1) Mod 13) = 12 Then
TempDeck(X) = "King"
Else
TempDeck(X) = CStr(1 + ((X - 1) Mod 13))
End If
TempDeck(X) = TempDeck(X) & " of "
If (X - 1) \ 13 = 0 Then
TempDeck(X) = TempDeck(X) & "Spades"
ElseIf (X - 1) \ 13 = 1 Then
TempDeck(X) = TempDeck(X) & "Hearts"
ElseIf (X - 1) \ 13 = 2 Then
TempDeck(X) = TempDeck(X) & "Diamonds"
ElseIf (X - 1) \ 13 = 3 Then
TempDeck(X) = TempDeck(X) & "Clubs"
End If
Next
End If
End If
'Let us shuffle the deck
X = 52
For X = 52 To 1 Step -1
TempInt = Int(X * Rnd + 1)
Deck(X) = TempDeck(TempInt)
TempCard = TempDeck(X)
TempDeck(X) = TempDeck(TempInt)
TempDeck(TempInt) = TempCard
Next
End Sub

Everything is self-contained in this version; just pass it an array
dimensioned between 1 and 52 as in this example use:

Private Sub CommandButton1_Click()
Dim MyDeck(1 To 52) As String
ShuffleDeck MyDeck
Debug.Print MyDeck(1) & ", " & MyDeck(4) & ", " & MyDeck(43)
End Sub
 
Back
Top