Randomly Assigning Names to Items

The AssignNames5 macro in my most recent comment below randomly shuffles the List array. My Excel Toolbox now includes the following function to return a range or array with all rows and/or columns randomly shuffled:
    =Shuffle(RangeArray, [RowsOnly], [ColsOnly])
If RowsOnly is True, columns will remain with their shuffled rows.
If ColsOnly is True, rows will remain with their shuffled columns.
Default for both RowsOnly and ColsOnly is FALSE. An error is returned if both are TRUE; otherwise, they apply only when RangeArray is 2D.
See https://sites.google.com/view/MyExcelToolbox/

Re. the AssignNamesX macros in my three previous comments below, here is yet another version. This one is the simplest.

Sub AssignNames5()
    Dim ItemCount, NameCount, ListCount, List, Temp, i, n
    If Range("A2") = "" Or Range("G2") = "" Then Exit Sub
    ItemCount = Range("A2").End(xlDown).Row - 1
    NameCount = Range("G2").End(xlDown).Row - 1
    ListCount = IIf(NameCount < ItemCount, ItemCount, NameCount)
    List = Range("G2").Resize(ListCount).Value '2D base-1 column of names
    List = WorksheetFunction.Transpose(List) '1D base-1 array (row vector)
    'When more items than names, assign blank names
    For i = NameCount + 1 To ListCount 'Skipped if ListCount = NameCount
        List(i) = ""
    Next i
    'Randomly shuffle the values in List array
    For i = 1 To ListCount
        n = Int((ListCount * Rnd) + 1) 'Random number 1 to ListCount
        Temp = List(i)
        List(i) = List(n)
        List(n) = Temp
    Next i
    'Assign randomized values from List to items
    For i = 1 To ItemCount
        Range("B1").Offset(i) = List(i)
    Next i
    'Clear any remainder plus one cell
    For i = ItemCount + 1 To ListCount + 1
        Range("B1").Offset(i) = ""
    Next i
End Sub

See http://www.cpearson.com/excel/ShuffleArray.aspx

Re. the AssignNames3 macro in my previous comment below, here is yet another version. This one uses a SortedList that is automatically sorted by its random number Keys.

Sub AssignNames4()
    Const REPEAT_NAMES = False 'True to repeat names; False to assign blanks
    Dim ItemCount, NameCount, ListCount, Key, i, n
    If Range("A2") = "" Or Range("G2") = "" Then Exit Sub
    ItemCount = Range("A2").End(xlDown).Row - 1
    NameCount = Range("G2").End(xlDown).Row - 1
    ListCount = IIf(NameCount < ItemCount, ItemCount, NameCount)
    Dim List As Object
    Set List = CreateObject("System.Collections.SortedList")
    'Associate each name with a random number Key in List sorted by Key
    For i = 1 To ListCount
        Do
            Key = Rnd 'Random number 0 to 1
        Loop While List.ContainsKey(Key) 'Avoid duplicate Key
        If i > NameCount Then
            If REPEAT_NAMES Then
                'When more items than names, randomly repeat names
                n = Int((NameCount * Rnd) + 1) 'Random number 1 to NameCount
                List.Add Key, Range("G1").Offset(n)
            Else
                'When more items than names, assign blank names
                List.Add Key, ""
            End If
        Else 'Next name in column G
            List.Add Key, Range("G1").Offset(i)
        End If
    Next i
    'Assign randomized names (List is base-0 sorted by random number Keys)
    For i = 1 To ItemCount
        Range("B1").Offset(i) = List.GetByIndex(i - 1)
    Next i
    'Clear any remainder plus one cell
    For i = ItemCount + 1 To ListCount + 1
        Range("B1").Offset(i) = ""
    Next i
End Sub

If there is any difficulty with the following statement
    Set List = CreateObject("System.Collections.SortedList")
enable Microsoft .NET Framework 3.5 using Control Panel as described here:
https://learn.microsoft.com/en-us/dotnet/framework/install/dotnet-35-windows

Re. the AssignNames2 macro in my previous comment below, if the list of names (NameCount) is less than the list of items (ItemCount), then random names are assigned to the first NameCount items and blank names are assigned to the remaining items. The following AssignNames3 version assigns the blank names for this case randomly as suggested in the Tip's last paragraph.

Sub AssignNames3()
    Const REPEAT_NAMES = False 'True to repeat names; False to assign blanks
    Dim ItemCount, NameCount, NumberCount, i, j, k, temp
    If Range("A2") = "" Or Range("G2") = "" Then Exit Sub
    ItemCount = Range("A2").End(xlDown).Row - 1
    NameCount = Range("G2").End(xlDown).Row - 1
    NumberCount = IIf(NameCount < ItemCount, ItemCount, NameCount)
    'Associate a random number with each name
    ReDim tempArray(1 To NumberCount, 1 To 2)
    For i = 1 To NumberCount
        If i > NameCount Then
            If REPEAT_NAMES Then
                'When more items than names, randomly repeat names
                k = Int((NameCount * Rnd) + 1) 'Random number 1 to NameCount
                tempArray(i, 1) = Range("G1").Offset(k)
            Else
                'When more items than names, assign blank names
                tempArray(i, 1) = ""
            End If
        Else
            tempArray(i, 1) = Range("G1").Offset(i) 'Name from list
        End If
        tempArray(i, 2) = Rnd 'Random number 0 to 1
    Next i
    'Bubble sort random number values to randomize associated names
    For i = 1 To NumberCount - 1
        For j = i + 1 To NumberCount
            If tempArray(i, 2) > tempArray(j, 2) Then
                For k = 1 To 2
                    temp = tempArray(j, k)
                    tempArray(j, k) = tempArray(i, k)
                    tempArray(i, k) = temp
                Next k
            End If
        Next j
    Next i
    'Assign randomized names
    For i = 1 To ItemCount
        Range("B1").Offset(i) = tempArray(i, 1)
    Next i
    'Clear any remainder plus one cell
    For i = ItemCount + 1 To NumberCount + 1
        Range("B1").Offset(i) = ""
    Next i
End Sub

Notice the method for randomizing names assures a name is only assigned once as specified in the Tip's first paragraph. But if the following statement
    Const REPEAT_NAMES = False 'True to repeat names; False to assign blanks
is replaced by this statement
    Const REPEAT_NAMES = True 'True to repeat names; False to assign blanks
then when NameCount is less than ItemCount, names will be repeated randomly to avoid assigning any blank names to the remaining items. REPEAT_NAMES is ignored if NameCount >= ItemCount.

The Tip's macro has several issues. Here is an improved version:

Sub AssignNames2()
    Dim ItemCount, NameCount, AssignCount, i, j, k, temp
    If Range("A2") = "" Or Range("G2") = "" Then Exit Sub
    ItemCount = Range("A2").End(xlDown).Row - 1
    NameCount = Range("G2").End(xlDown).Row - 1
    'Randomize Names
    ReDim tempArray(1 To NameCount, 1 To 2)
    For i = 1 To NameCount
        tempArray(i, 1) = Range("G1").Offset(i)
        tempArray(i, 2) = Rnd()
    Next i
    'Bubble Sort
    For i = 1 To NameCount - 1
        For j = i + 1 To NameCount
            If tempArray(i, 2) > tempArray(j, 2) Then
                For k = 1 To 2
                    temp = tempArray(j, k)
                    tempArray(j, k) = tempArray(i, k)
                    tempArray(i, k) = temp
                Next k
            End If
        Next j
    Next i
    'AssignNames
    AssignCount = IIf(NameCount > ItemCount, ItemCount, NameCount)
    For i = 1 To AssignCount
        Range("B1").Offset(i) = tempArray(i, 1)
    Next i
    k = IIf(NameCount < ItemCount, ItemCount, NameCount)
    For i = AssignCount + 1 To k + 1
        Range("B1").Offset(i) = ""
    Next i
End Sub

This macro assumes the following:
1. Row 1 has column headings assigned by the user.
2. The list of items is from cell A2 to the first blank cell in column A.
3. The list of names is from cell G2 to the first blank cell in column G.
4. The list of names assigned to items is in column B starting at cell B2 overwriting any previous content including blank cells down to one row below the list of items and names.