Excel打乱列数据：保证各值出现次数均等且无连续重复

你用=SORTBY(B2:B65,RANDARRAY(ROWS(B2:B65)))只能实现纯随机排序，但无法避免连续出现相同值，以下是两种可行的解决方案：

方法一：公式辅助法（无需宏） #

假设你的数据范围是B2:B65，按以下步骤操作：

1. 添加序号辅助列（D列）
   在D2单元格输入公式，下拉填充到D65：

   =COUNTIF($B$2:B2,B2)
   

   这个公式会给每个重复值标记递增序号（比如Bob第一次出现标1，第二次标2，以此类推），确保同值的每个实例有唯一序号。

2. 添加随机偏移辅助列（C列）
   在C2单元格输入公式，下拉填充到C65：

   =RAND() + D2/10000
   

   通过给同值的不同序号添加微小的固定偏移，避免随机排序时同值集中在一起。

3. 生成无连续重复的随机序列
   在空白单元格（比如E2）输入以下动态数组公式，按回车后会自动填充结果：

   =SORTBY(B2:B65,C2:C65)
   

   排序后同值会被均匀分散，基本不会出现连续重复的情况。如果偶尔出现，按F9刷新随机数即可重新生成。

方法二：VBA宏一键处理 #

如果需要频繁操作，VBA可以实现一键打乱且严格避免连续重复：

1. 按Alt+F11打开VBA编辑器，右键点击当前工作簿→插入→模块。
2. 粘贴以下代码（可修改Set rng = Range("B2:B65")为你的数据范围）：

   Sub ShuffleWithoutConsecutiveDuplicates()
       Dim rng As Range, arr(), uniqueVals(), counts()
       Dim i As Long, j As Long, k As Long, temp As Variant
       Dim newArr(), pos As Long, lastVal As String
       
       Set rng = Range("B2:B65") ' 替换为你的数据范围
       arr = rng.Value
       uniqueVals = Application.Unique(arr)
       ReDim counts(1 To UBound(uniqueVals))
       
       ' 统计每个值的出现次数
       For i = 1 To UBound(arr)
           For j = 1 To UBound(uniqueVals)
               If arr(i, 1) = uniqueVals(j, 1) Then
                   counts(j) = counts(j) + 1
                   Exit For
               End If
           Next j
       Next i
       
       ' 按值分组存储
       Dim groups() As Collection
       ReDim groups(1 To UBound(uniqueVals))
       For j = 1 To UBound(uniqueVals)
           Set groups(j) = New Collection
           For k = 1 To counts(j)
               groups(j).Add uniqueVals(j, 1)
           Next k
       Next j
       
       ' 随机抽取元素，确保不连续重复
       ReDim newArr(1 To UBound(arr), 1 To 1)
       lastVal = ""
       pos = 1
       
       Do While pos <= UBound(arr)
           ' 随机选非空且不等于上一个值的组
           Do
               j = Int((UBound(groups) - 1 + 1) * Rnd + 1)
           Loop Until groups(j).Count > 0 And groups(j)(1) <> lastVal
           
           ' 从选中组随机取一个元素
           k = Int((groups(j).Count - 1 + 1) * Rnd + 1)
           newArr(pos, 1) = groups(j)(k)
           groups(j).Remove k
           lastVal = newArr(pos, 1)
           pos = pos + 1
       Loop
       
       ' 将结果写入原数据右侧列（可修改Offset(0,1)调整输出位置）
       rng.Offset(0, 1).Value = newArr
   End Sub
   

3. 按F5运行宏，结果会自动写入数据右侧的列，每个值出现次数不变且无连续重复。

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