如何打乱VBA中Collection对象内的唯一名称项顺序？

你已经通过代码创建了存储唯一名称的uniqueNames Collection，要实现每次操作前打乱其中项的顺序，可以借助Fisher-Yates洗牌算法来完成——由于VBA的Collection不支持直接调整元素顺序，我们可以先将Collection内容转成数组，洗牌后再重建一个新的Collection。

洗牌函数实现 #

Function ShuffleCollection(col As Collection) As Collection
    Dim arr() As Variant
    Dim i As Long, j As Long
    Dim temp As Variant
    Dim newCol As New Collection
    
    ' 将Collection内容转换为数组
    ReDim arr(1 To col.Count)
    For i = 1 To col.Count
        arr(i) = col(i)
    Next i
    
    ' 执行Fisher-Yates洗牌
    Randomize ' 初始化随机数生成器，保证每次洗牌结果不同
    For i = UBound(arr) To LBound(arr) + 1 Step -1
        j = Int((i - LBound(arr) + 1) * Rnd + LBound(arr))
        temp = arr(i)
        arr(i) = arr(j)
        arr(j) = temp
    Next i
    
    ' 将洗牌后的数组重新存入Collection（保持唯一键）
    For i = LBound(arr) To UBound(arr)
        newCol.Add arr(i), CStr(arr(i))
    Next i
    
    Set ShuffleCollection = newCol
End Function

使用方法 #

在需要对uniqueNames进行操作前，调用上述函数重新赋值即可：

' 打乱uniqueNames的顺序
Set uniqueNames = ShuffleCollection(uniqueNames)

' 示例：遍历打乱后的Collection
Dim item As Variant
For Each item In uniqueNames
    Debug.Print item ' 替换为你的实际操作逻辑
Next item

原创建代码的简化优化 #

你原有的uniqueNames创建代码可以简化——无需判断Count = 0，On Error Resume Next已经能处理首次添加的情况：

Dim ws1 As Worksheet
Dim i As Long
Set ws1 = ThisWorkbook.Worksheets("Sheet1") ' 请替换为你的目标工作表名称
For i = 2 To ws1.Cells(ws1.Rows.Count, 1).End(xlUp).Row
    If ws1.Cells(i, 3).Value < 20 Then
        On Error Resume Next
        uniqueNames.Add ws1.Cells(i, 2).Value, CStr(ws1.Cells(i, 2).Value)
        On Error GoTo 0
    End If
Next i

内容的提问来源于stack exchange，提问作者Shinaj