Randomizer / Pairing

[juleskaynel]

I have a list of names and I want to randomly pair them in twos. How would I do this in Excel?

Example:
A1
A2
A3
A4
A5
A6
A7
A8

 

[Logit]

.

Option Explicit


Sub PickNamesAtRandom()


Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names() As String 'Array to store randomly selected names
Dim i As Byte
Dim CellsOut As Long 'Variable to be used when entering names onto worksheet
Dim ArI As Byte 'Variable to increment through array indexes


Application.ScreenUpdating = False


HowMany = Range("D3").Value
CellsOut = 6


ReDim Names(1 To HowMany) 'Set the array size to how many names required
NoOfNames = Application.CountA(Range("A:A")) - 1 ' Find how many names in the list
i = 1


Do While i <= HowMany
RandomNo:
    RandomNumber = Application.RandBetween(2, NoOfNames + 1)
    'Check to see if the name has already been picked
    For ArI = LBound(Names) To UBound(Names)
        If Names(ArI) = Cells(RandomNumber, 1).Value Then
            GoTo RandomNo
        End If
    Next ArI
    Names(i) = Cells(RandomNumber, 1).Value ' Assign random name to the array
    i = i + 1
Loop


'Loop through the array and enter names onto the worksheet
For ArI = LBound(Names) To UBound(Names)


    Cells(CellsOut, 4) = Names(ArI)
    CellsOut = CellsOut + 1


Next ArI


Application.ScreenUpdating = True


End Sub

Download workbook : https://www.amazon.com/clouddrive/share/LN8HkIt50z2BVQaiFu7IQDiRZUyF8Ay9STD8we51za4

 

[joeu2004]

Try the following VBA procedure.

Option Explicit

Sub randomPairs()
Dim v As Variant
Dim nv As Long, npair As Long
Dim i As Long, j As Long, x As Long

' Change "a1" to first cell of column of names
v = Range("a1", Range("a1").End(xlDown))
nv = UBound(v, 1)
npair = nv \ 2     ' truncate if nv is odd number (!)

ReDim pairs(1 To npair, 1 To 2) As Variant
Randomize
For i = 1 To npair: For j = 1 To 2
    x = Int(nv * Rnd) + 1
    pairs(i, j) = v(x, 1)
    If x <> nv Then v(x, 1) = v(nv, 1)
    nv = nv - 1
Next j, i

' change "b1" to first cell of pairs output
Range("b1").Resize(npair, 2) = pairs
End Sub

Some implementation notes:

1. I think VBA Rnd is good enough, considering the few number of pairs. But if you want a "better" randomizer, delete the Randomize statement, and replace the "x=..." statement as follows:

x = WorksheetFunction.RandBetween(1, nv)

2. Generally, it is good practice to use type Long for all integer variables. There is no benefit to using other integer data types; and they can lead to unnecessary, arbitrary and probably unintended limitations. For example, using type Byte limits the list to 255 names. Probably not a "game changer". But why bother? (Rhetorical.)

3. Do the following to create a VBA procedure ("macro"):

a. In Excel, right-click on the worksheet tab, and click View Code.
b. In VBA (*), copy the code above into the VBA Editor pane, usually on the right.
c. Save the file as "xlsm" (macro-enabled).

(*) Optionally, click Insert > Module before copying the code into the VBA Editor pane. Arguably, this is a "good practice".

4. To execute the procedure, in Excel, press alt+f8, click the VBA procedure name, and click Run.

 

[joeu2004]

To late to edit....

Some implementation notes:

5. The use of Range("a1").End(xlDown) assumes that the column of names is followed by an empty cell.

 

[Rick Rothstein]

Here is another macro for you to consider...

Sub RandomPairing()
  Dim Cnt As Long, RandomIndex As Long, Tmp As Variant, Arr As Variant
  Randomize
  Arr = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  For Cnt = UBound(Arr) To 1 Step -1
    RandomIndex = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
    Tmp = Arr(RandomIndex, 1)
    Arr(RandomIndex, 1) = Arr(Cnt, 1)
    Arr(Cnt, 1) = Tmp
  Next
  Range("B1").Resize(UBound(Arr)) = Arr
  Range("B1").Offset((1 + UBound(Arr)) / 2).Resize(UBound(Arr)).Cut Range("C1")
End Sub

 

[joeu2004]

Here is another macro for you to consider

Odd: it works with 8 names, but not with 10 names.

Aside.... I should add that my implementation assumes that there are at least 2 names. It works with only 1 name, quite by accident. But it takes an unnecessarily long time.

 

[Rick Rothstein]

Odd: it works with 8 names, but not with 10 names.

My code works with 10 names for me. As a matter of fact, I just tried it with 1000 names and it worked nearly instantaneously for them as well.

 

[joeu2004]

Range("B1").Offset((1 + UBound(Arr)) / 2).Resize(UBound(Arr)).Cut Range("C1")

My code works with 10 names for me

I don't know if or what code Rick tested, but his posted code certainly does not work for 10. By "does not work", I mean: it leaves two unpaired names in column B, as shown below.

In fact, it fails for all "n" names, where "n" is 4*k+2, k=0,1,etc. Thus, it fails for every other even number of names: 2, 6, 10,..., 998, 1002, etc.

So yes, it does work for 8 and 1000 names. But only by coincidence.

Rick's mistake is using forward-slash ("/"; floating-point divide) instead of back-slash ("\"; integer divide) or Int((1 + UBound(Arr)) / 2).

Consequently, with 10 names, Ubound(Arr) is 10 (despite Option Base 0, explicitly or by default), and (1+Ubound(Arr))/2 = 11/2 = 5.5. That rounds up to 6. And Range("B1").Offset(6) is B7, not B6 as intended.

The result is shown below. Note that B5 and B6 are unpaired. Actually, the problem is: B6 is "orphaned" when Rick does Range.Cut.

In contrast, with 1000 names, (1+Ubound(Arr))/2 = 1001/2 = 500.5. That rounds down to 500, as intended, because VBA does "banker's rounding" (round half to even).

With 10 names, the result of Rick's posted code is:

[TABLE="class: grid, width: 200"]
<tbody>[TR]
[TH][/TH]
[TH]A[/TH]
[TH]B[/TH]
[TH]C[/TH]
[/TR]
[TR]
[TD="align: center"]1[/TD]
[TD]a1[/TD]
[TD]a3[/TD]
[TD]a7[/TD]
[/TR]
[TR]
[TD="align: center"]2[/TD]
[TD]a2[/TD]
[TD]a9[/TD]
[TD]a6[/TD]
[/TR]
[TR]
[TD="align: center"]3[/TD]
[TD]a3[/TD]
[TD]a10[/TD]
[TD]a4[/TD]
[/TR]
[TR]
[TD="align: center"]4[/TD]
[TD]a4[/TD]
[TD]a5[/TD]
[TD]a2[/TD]
[/TR]
[TR]
[TD="align: center"]5[/TD]
[TD]a5[/TD]
[TD]a8[/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]6[/TD]
[TD]a6[/TD]
[TD]a1[/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]7[/TD]
[TD]a7[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]8[/TD]
[TD]a8[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]9[/TD]
[TD]a9[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[/TR]
[TR]
[TD="align: center"]10[/TD]
[TD]a10[/TD]
[TD="align: right"][/TD]
[TD="align: right"][/TD]
[/TR]
</tbody>[/TABLE]

 

[veyselemre]

Sub test()
    [B:C].ClearContents
    son = Cells(Rows.Count, 1).End(3).Row
    lst = Application.Transpose(Range("A1:A" & son).Value)
    For i = 1 To (son * 5)
        s1 = WorksheetFunction.RandBetween(1, son)
        s2 = WorksheetFunction.RandBetween(1, son)
        If s1 <> s2 Then
            tmp = lst(s2)
            lst(s2) = lst(s1)
            lst(s1) = tmp
        End If
    Next i
    For i = 1 To son Step 2
        say = say + 1
        Cells(say, 2) = lst(i)
        Cells(say, 3) = lst(i + 1)
    Next i
End Sub

 

[Rick Rothstein]

I don't know if or what code Rick tested, but his posted code certainly does not work for 10. By "does not work", I mean: it leaves two unpaired names in column B, as shown below.

You are correct (as is the analysis you posted as well). My mistake was in forgetting that arrays formed by assigning a range to a Variant variable are always one-based (I set my code up as if they were zero-based). The correction is simple, though, all that is needed is to not add 1 to the UBound(Arr) in the code line you quoted in Message#8. Here is the corrected code...

Sub RandomPairing()
  Dim Cnt As Long, RandomIndex As Long, Tmp As Variant, Arr As Variant
  Randomize
  Arr = Range("A1", Cells(Rows.Count, "A").End(xlUp))
  For Cnt = UBound(Arr) To 1 Step -1
    RandomIndex = Int((Cnt - LBound(Arr) + 1) * Rnd + LBound(Arr))
    Tmp = Arr(RandomIndex, 1)
    Arr(RandomIndex, 1) = Arr(Cnt, 1)
    Arr(Cnt, 1) = Tmp
  Next
  Range("B1").Resize(UBound(Arr)) = Arr
  Range("B1").Offset(UBound(Arr) / 2).Resize(UBound(Arr)).Cut Range("C1")
End Sub