Question

我试图在VBA中随机调整一组字符串，同时确保没有任何项目保留在同一个地方。

到目前为止，我一直在将所有项目添加到集合中，然后将旧数组映射到混洗数组，我遍历项目。每个项目都从集合中移除（因此项目永远不会转换为自身）。然后它从剩余的值中选择一个随机项，从集合中删除，并将自己添加回集合（因此后一项可以选择它）。

然而，偶尔这意味着最后一件物品永远不会被挑选，因为最后一件物品不能自己挑选，而所有其他物品都可以自己挑选一些东西

指数填充了所有人，目标和人都是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

对这些项目进行改组是这些项目的排列。没有项目保留在其原始位置的排列是 deranged 排列。参见：

Wikipedia Article

这是一个非常简单的算法。演示代码用于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

示例输出：

另一种方法是：

创建所有排列的列表
从该列表中删除非奇怪的排列以形成候选列表
随机挑选一名候选人。

Answer 2

这是Chip Pearson的功能＆gt;

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

Function ShuffleArray(InArray() As Variant) As Variant()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArray
' This function returns the values of InArray in random order. The original
' InArray is not modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Dim N As Long
    Dim Temp As Variant
    Dim J As Long
    Dim Arr() As Variant


    Randomize
    L = UBound(InArray) - LBound(InArray) + 1
    ReDim Arr(LBound(InArray) To UBound(InArray))
    For N = LBound(InArray) To UBound(InArray)
        Arr(N) = InArray(N)
    Next N
    For N = LBound(InArray) To UBound(InArray)
        J = CLng(((UBound(InArray) - N) * Rnd) + N)
        Temp = Arr(N)
        Arr(N) = ARr(J)
        Arr(J) = Temp
    Next N
    ShuffleArray = Arr
End Function

Answer 3

一个改编的shuffle数组，用于考虑在混洗数组中没有项目应该处于相同的位置。它使用与David G.提供的相同的初始代码，但随后测试碰撞并与另一个随机成员交换单个碰撞，或者如果发现多个碰撞，则将碰撞子集循环一个。

我已经使用字符串数组进行测试......

Sub TestShuffle()
    Dim Arr() As String
    Arr = Split("1;2;3;4;5", ";")
    Debug.Print Join(ShuffleArray(Arr), ",")
End Sub

Function ShuffleArray(InArray() As String) As String()
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' ShuffleArray
' This function returns the values of InArray in random order. The original
' InArray is not modified.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''

    If UBound(InArray) = 1 Then
        ShuffleArray = InArray
        Exit Function
    End If

    Dim N As Long
    Dim Temp As Variant
    Dim J As Long
    Dim Arr() As String
    Dim Collisions As Collection: Set Collisions = New Collection

    Randomize
    L = UBound(InArray) - LBound(InArray) + 1
    ReDim Arr(LBound(InArray) To UBound(InArray))
    For N = LBound(InArray) To UBound(InArray)
        Arr(N) = InArray(N)
    Next N
    For N = LBound(InArray) To UBound(InArray)
        J = CLng(((UBound(InArray) - N) * Rnd) + N)
        Temp = Arr(N)
        Arr(N) = Arr(J)
        Arr(J) = Temp
    Next N

    For N = LBound(InArray) To UBound(InArray)
        If Arr(N) = InArray(N) Then Collisions.Add N
    Next N

    If Collisions.Count > 1 Then
        Temp = Arr(Collisions.Item(1))
        For N = 1 To Collisions.Count - 1
            Arr(Collisions.Item(N)) = Arr(Collisions.Item(N + 1))
        Next N
        Arr(Collisions.Item(N)) = Temp
    ElseIf Collisions.Count = 1 Then
        J = Collisions.Item(1)
        Do Until J <> Collisions.Item(1)
            J = CLng((UBound(InArray) - LBound(InArray)) * Rnd) + LBound(InArray)
        Loop
        Temp = Arr(Collisions.Item(1))
        Arr(Collisions.Item(1)) = Arr(J)
        Arr(J) = Temp
    End If

    ShuffleArray = Arr

End Function

随机播放一个数组，以便没有项目保持在同一位置

3 个答案: