唯一 ID 生成器和随机器

Question

我正在为 Secret Santa 电子表格尝试一些项目。

1. 一个唯一 ID 生成器，用于在 B 列中打印 UID，以获得 A 列中的名称列表。

2. 一个随机化器，用于在 C 列中以随机顺序打印 ID 号，并限制 B 列 UID 不能等于 C 列 UID，确保没有人得到自己。

3. D 列 C 列中随机 UID 的列表名称。

UID 从 1 开始计数，直到姓氏收到 ID。我还希望生成器为添加到列表中任何位置（开头、中间、结尾）的名称创建 ID。

我在这里和其他网站上找到了一些答案。
有些使用复杂的循环其他我不明白的 GUID 功能。
一般来说，答案是针对现有列表而不是没有 UID 的新列表。

我想我会：

1. 创建 UID 并将它们打印到 B 列。
2. 将 A 列和 B 列保存到一个数组中。
3. 将 UID 随机化并打印到 C 列中。
4. 使用数组在 C 列中获取随机 UID 的名称，并在 D 列中打印相应的名称。

我不确定这种方法是否是解决此类问题的“好”方法，但我有兴趣了解其他方法。

到目前为止，我唯一的代码是行计数器。

Sub secret_santa()
    
    Dim person_count As Integer
    Dim uid As Integer
       
    'Count Number of Used Rows
    person_count = ActiveSheet.UsedRange.Rows.Count
        
    'Subtract Header from person_count
    person_count = person_count - 1
       
End Sub

Answer 1

如果我没看错，你基本上只是想对数组进行洗牌，同时还施加一个约束，即没有 user ID 不能最终对应于自身。

您可以通过多种方式实现这一点。下面的方法不是很通用，可以重构（使用更多的函数/子例程）并且有点笨拙。尽管如此，它可能没问题，并且可能会给您一些关于实施的想法：

Option Explicit

Private Function GetArrayOfNames(ByVal someRange As Range) As Variant
    ' someRange should be a single-column, vertical range.
    Debug.Assert someRange.Columns.Count = 1
    Debug.Assert someRange.Areas.Count = 1
    Debug.Assert someRange.Rows.Count > 1

    GetArrayOfNames = someRange.Value
End Function

Private Sub SecretSantaShuffle()
    ' This procedure will overwrite the contents of the initial range,
    ' and the three columns to its right.
    Dim rangeContainingNames As Range
    Set rangeContainingNames = ThisWorkbook.Worksheets("Sheet1").Range("A2:A7")

    Dim inputArray() As Variant
    inputArray = GetArrayOfNames(rangeContainingNames)

    Dim rowCount As Long
    rowCount = UBound(inputArray, 1)

    ReDim Preserve inputArray(1 To rowCount, 1 To 4)

    Const NAME_COLUMN_INDEX As Long = 1
    Const UID_COLUMN_INDEX As Long = 2
    Const RANDOM_NAME_COLUMN_INDEX As Long = 3
    Const RANDOM_UID_COLUMN_INDEX As Long = 4

    Do
        Dim userIdPool As Collection
        Set userIdPool = New Collection

        Dim rowIndex As Long
        For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
            inputArray(rowIndex, UID_COLUMN_INDEX) = rowIndex
            userIdPool.Add rowIndex, Key:=CStr(rowIndex)
        Next rowIndex

        For rowIndex = LBound(inputArray, 1) To UBound(inputArray, 1)
            Dim randomRowIndex As Long

            Do While True
                randomRowIndex = userIdPool.Item(Application.RandBetween(1, userIdPool.Count))
                If randomRowIndex <> rowIndex Then Exit Do
                If userIdPool.Count = 1 Then Exit Do
                DoEvents
            Loop

            userIdPool.Remove CStr(randomRowIndex)

            inputArray(rowIndex, RANDOM_NAME_COLUMN_INDEX) = inputArray(randomRowIndex, NAME_COLUMN_INDEX)
            inputArray(rowIndex, RANDOM_UID_COLUMN_INDEX) = inputArray(randomRowIndex, UID_COLUMN_INDEX)
        Next rowIndex
    Loop While userIdPool.Count > 0

    rangeContainingNames.Resize(UBound(inputArray, 1), UBound(inputArray, 2)).Value = inputArray
End Sub

您可能需要更改分配给rangeContainingNames 的内容。我的姓名列表在工作表 Sheet1 的范围 A2:A7 中，但您应该更改工作表名称和范围地址以反映您姓名的位置。