在 VBA 中打乱一组行

Question

我是 VBA 的新手，所以我在解决这个问题时遇到了一些问题。

我有一组行，我必须记录一个宏来随机播放所有行。也就是说，在我运行宏之后，必须没有任何行保持不变。

事实是，这组值不是单个列。有几列必须考虑在内。必须在不更改整行的情况下进行洗牌，并且必须对所有列进行洗牌。

一个非常简单的例子： 洗牌前的值：

一个

B 2

C 3

洗牌后：

C 3

一个

B 2

此外，此代码每次运行时都必须生成随机订单，因此必须具有灵活性。

编辑：我尝试过使用 VLookup，但它变得非常复杂并且无法正常运行。

Sub Shuffle()

Dim i as Variant
Dim j as Variant
Dim myTable as Range
Set myTable = Sheets(1).Range("A1:C10")

'after setting everything up I tried getting the entire row and assigning it to variables, in the worksheet I have 3 columns.
For i=1 to myTable.Rows.Count
Col1=Application.WorksheetFunction.Vlookup(...

在这里，我试图在选择第一个值时捕获其他列的值。但问题是第一个值必须随机选择。这并不一定意味着我将为第一列选择的值与我将选择的行不应该相同。我的数据接近于：

1个M

1乙男

1 C K

2 A M..等等。

所以对于第一行，我还必须能够选择以下两行，这是我无法通过 Vlookup 函数满足的。也许行的索引值可用于随机化，但我不知道该怎么做。

非常感谢您。

Answer 1

假设您在 A2:B27 中有数据，在 A1:B1 中有标题。在 C1 中，输入“OriginalRow”，在 D1 中输入“Rand”。

此代码对 Rand 列上的行进行排序，直到每一行位于不同的位置。有 26 行，它很少占用 5 个循环。即使只有三排，也很少尝试超过 7 次。

Public Sub Shuffle()

    Dim lCnt As Long
    Dim rRng As Range

    Set rRng = Sheet1.Range("A2:D27")

    'Record which row it starts on
    With rRng.Columns(3)
        .Formula = "=ROW()"
        .Value = .Value
    End With

    Do
        'Add a random value for sorting
        With rRng.Columns(4)
            .Formula = "=RAND()"
            .Value = .Value
        End With

        'Sort on random value
        Sheet1.Sort.SortFields.Clear
        Sheet1.Sort.SortFields.Add rRng.Columns(4), xlSortOnValues, xlAscending
        With Sheet1.Sort
            .SetRange rRng.Offset(-1).Resize(rRng.Rows.Count + 1)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .Apply
        End With

        lCnt = lCnt + 1
    'if any rows are the same as the starting row
    'do it again
    Loop Until ShuffleComplete(rRng.Columns(3)) Or lCnt > 100

    Debug.Print lCnt

End Sub

Public Function ShuffleComplete(rRng As Range) As Boolean

    Dim rCell As Range
    Dim bReturn As Boolean

    bReturn = True

    For Each rCell In rRng.Cells
        If rCell.Value = rCell.Row Then
            bReturn = False
            Exit For
        End If
    Next rCell

    ShuffleComplete = bReturn

End Function

Answer 2

我一直在寻找相同的解决方案，并从这个 site 找到了 DharanSailor 的解决方案。试试吧！