random fill

[jbmahoney]

Is there any way to populate a table randomly, with say names and used only once. I am trying to randomly place a 30 people into 6 groups of five?

Can this be done randomly?

 

[jindon]

Hi

Take a look at
http://www.mrexcel.com/board2/viewtopic.php?t=154990&postdays=0&postorder=asc&start=10

 

[BrianB]

Try this :-

Sub test()
    Dim NameList As Range
    Dim MyName As String
    Dim NameNumber As Integer
    Dim ResultsTable As Range
    Dim NumFound As Boolean
    Dim MyRand As Integer
    '----------------------------------------------
    Set NameList = ActiveSheet.Range("A1:A30")
    Set ResultsTable = ActiveSheet.Range("C1:H5")
    ResultsTable.ClearContents
    '- main loop
    For NameNumber = 1 To 30
        MyName = NameList.Cells(NameNumber, 1).Value
        NumFound = False
        While NumFound = False
            MyRand = Int(Rnd * 30) + 1
            If ResultsTable.Cells(MyRand).Value = "" Then
                ResultsTable.Cells(MyRand).Value = MyName
                NumFound = True
            End If
        Wend
    Next
    MsgBox ("Done")
End Sub

 

[jbmahoney]

thanks very much, thats great!

thanks for your help, much appreciated.

 

[erik.van.geit]

Hi, guys,

for your information
when you are going to pick items this way you create loops which can be avoided (or else I'm missing something here)
this is no problem using little tables but with larger ones (more then 500) your code could run longer then necessary to find the last items
trying to explain this

'DATA
'A B C D E
'item found     items left      scenario finding value
'D              A B C E         D
'D B            A C E           B
'D B A          C E             B D A
'D B A C        E               D C
'D B A C E                      A A D B E
'this scenario looped 12 times instead of 5

'test looped 500 times the code using random pick
'items      loops
'10         30
'20         60
'30         120
'60         280
'120        650

Brians code tested with 3000 items is still working fine in some seconds(other code not tested)
here my suggestion
use extra column to fill with random values and sort with this column as the key
pick values in the sorted order
restore order in original list

Option Explicit

Sub random_teams()
'Erik Van Geit
'051101
'quick random sort
'COLUMN B must be empty
Dim NameList As Range
Dim ResultsTable As Range
Dim mem As Variant

Application.ScreenUpdating = False
    Set NameList = ActiveSheet.Range("A1:A30")
    mem = NameList
    Set ResultsTable = ActiveSheet.Range("C1:H5")
    With NameList
        With .Offset(0, 1)
        .Formula = "=RAND()"
        .Value = .Value
        End With
    .Resize(.Rows.Count, 2).Sort key1:=NameList(1).Offset(0, 1), order1:=1
    .Offset(0, 1).ClearContents
    End With
    
    ResultsTable.ClearContents
    For NR = 1 To NameList.Cells.Count
    ResultsTable.Cells(NR).Value = NameList.Cells(NR, 1).Value
    Next
    
NameList = mem
Application.ScreenUpdating = True
End Sub

kind regards,
Erik

 

[NateO]

Hello,

Hmm... I've worked with this problem before, working through different versions of logic... Here's the latest variety I've come up with:

http://www.utteraccess.com/forums/showflat.php?Number=425569&fpart=2.6

Not sure if it helps or not, but it might be worth reviewing...

 

[erik.van.geit]

Nate,

that's the kind of logic I like
must be faster then my code
(didn't test speed)
if you allow me to ask:
what's the quickest way to write a one-dimension-array (result of your code) back to the sheet in two dimensions ?
example
your array has 30 items
writing to C1:H5

kind regards,
Erik

 

[NateO]

Hi Erik,

Actually, that code uses a 2-d array, with 10 elements (in the test), which a vertical column is like... You can see it here:

ReDim Arr2(1 To Output.Rows.Count, 1 To 1)

That is, RedDim Arr2(Dimension 1, Dimension 2)

The fastest way would be to structure the array with the dimensions as you want them and stack it as such.

 

[erik.van.geit]

NateO,
you're right about 2-d
but I meant only one column: so using the "bad" expression 1-d
also glad you didn't provide a finished-solution
so my brain was invited to create something
(surely it was invernting the wheel)

this code will transpose range to another, all calculations being done in memory
can you think of speedenhancement ?
(on my "slow" machine entire column took about 10 seconds to transpose)
can this be made shorte-quicker ?
arr2(Int((i - 1) / c) + 1, IIf(i Mod c, i Mod c, c)) = arr1(i, 1)
especially "IIf(i Mod c, i Mod c, c)"

Option Explicit
Option Base 1

Sub transpose()
'Erik Van Geit
'051102

'please set:
'column with sourcedata
'first cell for new range
'number of columns to transpose

'no problem:
'if # of columns is to large
'if the last row will not be filled entirely

Dim arr1 As Variant
Dim arr2 As Variant
Dim i As Long
Dim r As Long
Dim rng1 As Range
Dim rng2 As Range

Const col As Integer = 1    'column with source data
Set rng2 = Cells(1, col + 2)    'first cell new range
Const c As Integer = 44     'number of columns

    If Cells(Rows.Count, 1) <> "" Then
    Set rng1 = Range(Cells(1, col), Cells(Rows.Count, col))
    Else
    Set rng1 = Range(Cells(1, col), Cells(Rows.Count, col).End(xlUp))
    End If


r = Int(rng1.Count / c) + 1

ReDim arr2(r, c)
arr1 = rng1

For i = 1 To UBound(arr1)
arr2(Int((i - 1) / c) + 1, IIf(i Mod c, i Mod c, c)) = arr1(i, 1)
Next i

    With rng2
    .Resize(Rows.Count, c).ClearContents
    .Resize(r, c).Value = arr2
    End With

End Sub

best regards,
Erik

 

[NateO]

Hi Erik,

I think you mean going from one column to two, right?

Here's a few thoughts. Frist, make the 2nd array a specific type, if you know what that type will be, I'll use an array of strings. Second, I always declare the lower boundary of dimensions. I see you start to iterate on 1 as the lower boundary, but you didn't specifically set your array to that. Is the lower boundary of arr2 equal to 0?

Here's what I had in mind:

Private Sub rnPk(List As Range, Output As Range)
Dim Arr1() As Variant, Arr2() As String
Dim f As Long, i As Long, j As Long
Dim cnt As Long
Arr1 = List
ReDim Arr2(1 To Output.Rows.Count, 1 To Output.Columns.Count)
Randomize
cnt = UBound(Arr1, 1)
For i = 1 To UBound(Arr2, 1)
    For j = 1 To UBound(Arr2, 2)
        f = Int((cnt - LBound(Arr1, 1) + 1) * _
            Rnd + LBound(Arr1, 1))
        Arr2(i, j) = Arr1(f, 1)
        Arr1(f, 1) = Arr1(cnt, 1)
        Arr1(cnt, 1) = Arr2(i, j)
        cnt = cnt - 1
    Next j
Next i
Output.Value = Arr2
End Sub

Sub foo()
Call rnPk([a1:a30], [c1:h5])
End Sub

Sub bar()
Call rnPk([a1:a30], [c1:c30])
End Sub

And calling foo() gives us:

Book1
	A	B	C	D	E	F	G	H
1	test1		test10	test28	test11	test16	test4	test24
2	test2		test6	test27	test22	test21	test13	test25
3	test3		test17	test26	test1	test15	test12	test5
4	test4		test19	test2	test14	test8	test20	test23
5	test5		test9	test18	test3	test30	test29	test7
6	test6
7	test7		No Duplicates
Sheet1

Simple logic, minimized array loop, no conditionals -> Fast process.

There's no error-trapping, so the output array had better have the same or less elements than the input array... If I've missed something here, I apologize...