Goal: randomization without doubling up two names Problem: comparing and writing (to worksheet) collection and/or arrays

Question

I am trying to write a simple randomizing program that reads from a column of names and randomly writes them to three columns of four. I have something that kind of works, but it is duplicating my names and I can figure out how to fix it with arrays or collections as those wont let me compare values. Thank you in advance.

Goal: randomization without doubling up two names

Problem: comparing and writing (to worksheet) collection and/or arrays

Option Explicit

Private Sub Randomize_Click()

Dim HowMany As Integer
Dim NoOfNames As Long
Dim RandomNumber As Integer
Dim Names(), dub() As String 'Array to store randomly selected names
Dim i, j, r, a, p 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 = 4 ' use with a third loops?
CellsOut = 4

  For a = 1 To 6
    For r = 1 To 3
       For j = 2 To 5
          'CellsOut = i 'turn this into loops

           ReDim Names(1 To 4) 'Set the array size to how many names required

           NoOfNames = Application.CountA(Worksheets("Employees").Range("A:A")) - 1 ' Find how many 
           names in the list


           i = 1
           Do While i <= HowMany
           RandomNo:
               RandomNumber = Application.RandBetween(2, NoOfNames + 1)
               dub = RandomNumber
               'dub.Add Unit.Value
                   If Names(i) = Cells(RandomNumber, 1).Value Then
                  'If Names(i) = dub(Unit) Then
                      GoTo RandomNo
                   End If
                   Names(i) = Worksheets("Employees").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, j) = Names(ArI)
                CellsOut = CellsOut + 1
            Next ArI
            Application.ScreenUpdating = True
            CellsOut = 4
        Next j
    Next r
Next a



End Sub

Display

Names

Answer 1

Random Names

Current Setup

• This solution uses the dictionary to randomize numbers which I was exploring earlier today.

• The complete code goes into a standard module.

• Adjust the three constants at the beginning of randomizeNames.

• You only run randomizeNames, e.g. via a command button:

   Private Sub Randomize_Click()
       randomizeNames
   End Sub
  

The Code

Option Explicit

Sub randomizeNames()
    
    ' Constants
    Const srcFirst As String = "A2"
    Const NoC As Long = 3
    Const tgtFirst As String = "C2"
    
    ' Define Source First Cell Range ('cel').
    Dim cel As Range
    Set cel = Range(srcFirst)
    ' Define Source Last Cell Range ('rng').
    Dim rng As Range
    Set rng = Cells(Rows.Count, cel.Column).End(xlUp)
    ' Define Source Column Range ('rng').
    Set rng = Range(cel, rng)
    ' Define Number of Elements (names) ('NoE').
    Dim NoE As Long
    NoE = rng.Rows.Count
    
    ' Write values from Source Column Range to Source Array ('Source').
    Dim Source As Variant
    If NoE > 1 Then
        Source = rng.Value
    Else
        ReDim Source(1 To 1, 1 To 1)
        Source(1, 1) = rng.Value
    End If
    
    ' Define Random Numbers Array ('RNA').
    Dim RNA As Variant
    ' This line uses both functions.
    RNA = getDictionary(Dictionary:=getRandomDictionary(1, NoE), _
                        FirstOnly:=True)
    
    ' Instead of numbers, write elements from Source Array
    ' to Random Number Array (Random Names Array).
    Dim i As Long
    For i = 1 To NoE
        RNA(i, 1) = Source(RNA(i, 1), 1)
    Next i
    
    ' Define Number of Rows in Target Array ('NoR') and the Remainder
    ' of elements ('Remainder').
    Dim NoR As Long
    NoR = Int(NoE / NoC)
    Dim Remainder As Long
    Remainder = NoE Mod NoC
    If Remainder > 0 Then
        NoR = NoR + 1
    Else
        Remainder = NoC
    End If
    
    ' Define Target Array ('Target').
    Dim Target As Variant
    ReDim Target(1 To NoR, 1 To NoC)
    
    ' Declare additional variables.
    Dim j As Long ' Target Array Columns Counter
    Dim k As Long ' Random Names Array Rows Counter
    
    ' Write values from Random Names Array to Target Array.
    For i = 1 To NoR - 1
        For j = 1 To NoC
            k = k + 1
            Target(i, j) = RNA(k, 1)
        Next j
    Next i
    For j = 1 To Remainder
        k = k + 1
        Target(i, j) = RNA(k, 1)
    Next j
        
    ' Define Target First Cell Range ('cel').
    Set cel = Range(tgtFirst)
    ' Clear contents from Target First Cell Range to bottom-most cell
    ' of last column of Target Range.
    cel.Resize(Rows.Count - cel.Row + 1, NoC).ClearContents
    ' Write values from Target Array to Target Range.
    Range(tgtFirst).Resize(NoR, NoC).Value = Target
    
End Sub

Function getRandomDictionary(ByVal LowOrHigh As Long, _
                             ByVal HighOrLow As Long) _
         As Object
    
    ' Define Numbers Dictionary ('dict').
    Dim dict As Object
    Set dict = CreateObject("Scripting.Dictionary")
    
    ' Define the lower number ('Minimum') and the Number of Elements ('NoE').
    Dim NoE As Long
    Dim Minimum As Long
    If LowOrHigh < HighOrLow Then
        Minimum = LowOrHigh
        NoE = HighOrLow - LowOrHigh + 1
    Else
        Minimum = HighOrLow
        NoE = LowOrHigh - HighOrLow + 1
    End If
    
    ' Write random list of numbers to Numbers Dictionary.
    Dim Current As Long
    Do
        ' Randomize ' Takes considerably longer.
        Current = Int(Minimum + NoE * Rnd)
        dict(Current) = Empty
    Loop Until dict.Count = NoE
    
    ' Write result.
    Set getRandomDictionary = dict

End Function

Function getDictionary(Dictionary As Object, _
                       Optional ByVal Horizontal As Boolean = False, _
                       Optional ByVal FirstOnly As Boolean = False, _
                       Optional ByVal Flip As Boolean = False) _
         As Variant
    
    ' Validate Dictionary.
    If Dictionary Is Nothing Then
        GoTo ProcExit
    End If
    Dim NoE As Long
    NoE = Dictionary.Count
    If NoE = 0 Then
         GoTo ProcExit
    End If
     
    ' Write values from Dictionary to Data Array ('Data').
    Dim Data As Variant
    Dim Key As Variant
    Dim i As Long
    If Not Horizontal Then
        If Not FirstOnly Then
            ReDim Data(1 To NoE, 1 To 2)
            If Not Flip Then
                For Each Key In Dictionary.Keys
                    i = i + 1
                    Data(i, 1) = Key
                    Data(i, 2) = Dictionary(Key)
                Next Key
            Else
                For Each Key In Dictionary.Keys
                    i = i + 1
                    Data(i, 1) = Dictionary(Key)
                    Data(i, 2) = Key
                Next Key
            End If
        Else
            ReDim Data(1 To NoE, 1 To 1)
            If Not Flip Then
                For Each Key In Dictionary.Keys
                    i = i + 1
                    Data(i, 1) = Key
                Next Key
            Else
                For Each Key In Dictionary.Keys
                    i = i + 1
                    Data(i, 1) = Dictionary(Key)
                Next Key
            End If
        End If
    Else
        If Not FirstOnly Then
            ReDim Data(1 To 2, 1 To NoE)
            If Not Flip Then
                For Each Key In Dictionary.Keys
                    i = i + 1
                    Data(1, i) = Key
                    Data(2, i) = Dictionary(Key)
                Next Key
            Else
                For Each Key In Dictionary.Keys
                    i = i + 1
                    Data(1, i) = Dictionary(Key)
                    Data(2, i) = Key
                Next Key
            End If
        Else
            ReDim Data(1 To 1, 1 To NoE)
            If Not Flip Then
                For Each Key In Dictionary.Keys
                    i = i + 1
                    Data(1, i) = Key
                Next Key
            Else
                For Each Key In Dictionary.Keys
                    i = i + 1
                    Data(1, i) = Dictionary(Key)
                Next Key
            End If
        End If
    End If
    
    ' Write result.
    getDictionary = Data

ProcExit:

End Function

List of US Top 30 Names

James
John
Robert
Michael
William
Mary
David
Joseph
Richard
Charles
Thomas
Christopher
Daniel
Elizabeth
Matthew
Patricia
George
Jennifer
Linda
Anthony
Barbara
Donald
Paul
Mark
Andrew
Edward
Steven
Kenneth
Margaret
Joshua