arrays - 打乱数组，以便没有项目保留在同一位置

Question

我试图在 VBA 中随机打乱字符串数组，同时确保没有项目保留在同一位置。

到目前为止，我已经将所有项目添加到集合中，然后为了将旧数组映射到已打乱顺序的数组上，我循环遍历项目。每个项目都会从集合中删除自身(因此项目永远不会转变为自身)。然后，它从剩余值中随机选择一个项目，从集合中删除该，并将自身添加回集合中(以便后面的项目可以选择它)。

但是，这有时意味着最后一个项目永远不会被选中，因为最后一个项目无法自行挑选，而所有其他项目都可以在它们之间挑选一些东西

Indices 填充了所有人员，目标和人员都是 1 索引数组，其中后者是要洗牌的数组。

For i = 1 To UBound(people) ' loop through people
    stillHere = HasKey(indices, "person" & i) 'only remove self from list if not already taken
    If stillHere Then indecies.Remove "person" & i
    randNum = Application.WorksheetFunction.RandBetween(1, indices.Count)
    targets(i) = people(indices(randNum))
    If indices.Count > 1 Then indices.Remove (randNum) 'don't remove the last item of the collection
    If stillHere Then indices.Add i, "person" & i 'only add self back if not already taken
Next i

Answer 1

项目的洗牌是这些项目的排列。没有任何项目保留在其原始位置的排列是困惑排列。请参阅:

Wikipedia Article

这是一个非常简单的算法。演示代码用于 5 个项目:

1. 狗
2. 猫
3. 鼠标
4. 鸟
5. 鱼

对于输出数组中的每个位置，我们构建一个候选列表，从中进行随机选择。因此第一个输出的候选者排除了“dog”。第二个输出的候选排除“cat”以及为第一个输出选择的任何内容。

每个输出的候选列表都会缩小。最后一个输出的候选列表仅包含一个项目，因此我们选择它。

最后的输出可能与最后的输入相同。如果发生这种不良事件，我们只需交换第一个和最后一个输出。

Sub MAIN()
    Dim inpt(1 To 5) As String, Candidate(), j As Long
    Dim i As Long, outpt(), Temp, UTemp As Long
    Dim U As Long, x

    inpt(1) = "dog"
    inpt(2) = "cat"
    inpt(3) = "mouse"
    inpt(4) = "bird"
    inpt(5) = "fish"
    U = UBound(inpt)

    ReDim outpt(1 To U)
    ReDim Candidate(1 To U)
    For i = 1 To U
        Candidate(i) = inpt(i)
    Next i

    For i = 1 To U
        If UBound(Candidate) = 1 Then
            outpt(i) = Candidate(1)
        Else
            outpt(i) = PickValue(Exclude(Candidate, inpt(i)))
            Temp = Exclude(Candidate, outpt(i))
            UTemp = UBound(Temp)
            ReDim Candidate(1 To UTemp)
            For j = 1 To UTemp
                Candidate(j) = Temp(j)
            Next j
        End If

        If inpt(U) = outpt(U) Then
            x = outpt(U)
            outpt(U) = outpt(1)
            outpt(1) = x
        End If



        Cells(i, 2) = inpt(i)
        Cells(i, 4) = outpt(i)

    Next i


End Sub

Exclude() 函数输入一个数组和一个要排除的值，并输出一个从中进行排除的精简数组:

Public Function Exclude(ary As Variant, xClude As Variant) As Variant
    Dim c As Collection, i As Long, cCount As Long
    Set c = New Collection

    For i = LBound(ary) To UBound(ary)
        If ary(i) = xClude Then
        Else
            c.Add ary(i)
        End If
    Next i

    cCount = c.Count
    ReDim bry(1 To c.Count)
    For i = 1 To cCount
        bry(i) = c.Item(i)
    Next i

    Exclude = bry
    Set c = Nothing
End Function

PickValue() 函数输入一个数组并从该数组输出一个随机项:

Public Function PickValue(ary) As Variant
    Dim L As Long, U As Long

    L = LBound(ary)
    U = UBound(ary)

        With Application.WorksheetFunction
            PickValue = ary(.RandBetween(L, U))
        End With
End Function

示例输出:

另一种方法是:

1. 创建所有排列的列表
2. 从该列表中删除未困惑的排列以形成候选列表
3. 随机选择一名候选人。