Random selection

[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

 

[joel]

try this code. It copies column B to column IU and then put a random
number into column IV. finally sorts the random number to and copies
results back to colun D.



Sub getRandomCard()

'copy column b to column IU
Columns("B").Copy _
Destination:=Columns("IU")

'get last row
LastRow = Range("IU" & Rows.Count).End(xlUp).Row

'put random numbers in column IV
Range("IV1:IV" & LastRow) = "=rand()"

'replace formula with values
Columns("IV").Copy
Columns("IV").PasteSpecial Paste:=xlPasteValues

'sort columns IU and IV
Range("IU1:IV" & LastRow).Sort _
header:=xlNo, _
key1:=Range("IV1"), _
Order1:=xlAscending

'get 5% of values
endrow = Int(0.05 * LastRow)
If endrow >= 1 Then

'copy 5% value into column D
Range("IU1:IU" & endrow).Copy _
Range("D1")

End If
'delete columns IU and IV
Columns("IU:IV").Delete


End Sub

 

[Mike H]

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").ClearContents
LastRow = sht.Cells(Cells.Rows.Count, "B").End(xlUp).Row
NumCards = Int(LastRow * 0.05)
Set FillRange = sht.Range("D1" & 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.

 

[p45cal]

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 t select
randomly 5% of the cards and copy it in column D.

Is possible to do this?

Thanks for your attention

or this:
some explanation in the code as comments:


VBA Code:
--------------------


Sub blah()
'Using a single column of data whose top DATA cell is defined by TLCell and whose bottomost cell is defined as the cell above the first blank cell below TLCell,
'This macro uses the column immediately to the right briefly, to put formulae in and leaves results in the column to the right of that.
'It will overwrite anything in the two columns immediately to the right of the TLCell column.
'It returns a percent (determined by the percentage variable) of the data (at random) at the top of a column 2 to the right of the TLCell column.
Dim TLCell As Range
Set TLCell = Range("B2") 'adjust to top cell of card DATA, not the header.
percentage = 5 'adjust to the percent you want to see. (eg. 5 = 5%)
Application.ScreenUpdating = False

Set Col1 = Range(TLCell, TLCell.End(xlDown))
With Col1
Col1Addr = Col1.Address(ReferenceStyle:=xlR1C1)
Col2Addr = Col1.Offset(, 1).Address(ReferenceStyle:=xlR1C1)
lastrw = .Count + .Row - 1
.Offset(, 1).FormulaR1C1 = "=RAND()"
.Offset(, 2).FormulaR1C1 = "=IF(ROW()-" & .Row - 1 & "<=(ROUND(" & .Count & "*" & percentage / 100 & _
",0)),INDEX(" & Col1Addr & ",MATCH(LARGE(" & Col2Addr & ",row()-" & .Row - 1 & ")," & Col2Addr & ",0)),"""")"
.Offset(, 2).Value = .Offset(, 2).Value
.Offset(, 1).Clear
End With
Application.ScreenUpdating = True
End Sub

 

[ozgrid.com]

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

 

[Bernd P]

Hello Marco,

I suggest to use my UDF Random_Pick which can also cope with multi-
ranges:
http://sulprobil.com/html/random_pick.html

Regards,
Bernd

 

[Marco Rod]

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:

 

[helene and gabor]

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

 

[helene and gabor]

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

 

[Marco Rod]

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

Thanks a lot Marco Rod

"helene and gabor" escreveu:

 

[joel]

My original code prevented duplicates. By copying the cards to a ne
column and sorting by a random number is equivalent to setting up a
array of of 52 cards. And using worksheet functions like sort and cop
is more efficient than copying the values into an array and manuall
osrting.

 

[Rick Rothstein]

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