[已解决]将选区表格的每列进行随机排序

荒野孤行

想实现的功能：把选取的表格数据的每列进行随机排列（各列数据不相互影响）← 数据仍填在原来的所选区域
如下是已写的源码，但是实现不了想要的功能，请大家帮忙看下需怎么修改。谢谢！


Sub 按列随机排序()
    Dim rng As Range, yRg As Range
    On Error Resume Next
    If TypeName(Selection) <> "Range" Then Exit Sub
    Set rng = Selection
    n = rng.Count
    If n = 1 Then '若选取的表格数为1
        MsgBox "请选择多个表格", vbExclamation, "提示"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    For Each yRg In rng
        n = yRg.End(xlUp).Row - yRg.Row + 1
        Set yRg = yRg.Resize(n)
        arr = yRg
        Randomize
        For i = 1 To n
            R = Int(Rnd * (n - i + 1)) + i '随机排序
            '开始调换数据，采用洗牌法
            t = arr(R, 1)
            arr(R, 1) = arr(i, 1)
            arr(i, 1) = t
        Next
        yRg = arr
    Next yRg
    Application.ScreenUpdating = True
End Sub

最佳答案

月排行榜 / 总排行榜

zjdh

2022-5-18 21:42

Sub 排序_选区按列随机排序()
    On Error Resume Next
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Count = 1 Then '若选取的表格数为1
        MsgBox "请选择多个表格", vbExclamation, "提示"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    arr = Selection
    Randomize Timer
    For J = 1 To UBound(arr, 2)
        For i = 1 To UBound(arr)
            R = Int(Rnd * UBound(arr)) + 1 '随机排序
            t = arr(R, J)
            arr(R, J) = arr(i, J)
            arr(i, J) = t
        Next
        Selection = arr
    Next
    Application.ScreenUpdating = True
End Sub

跳转到最佳答案楼层

荒野孤行

或者这种？不知道哪里出错

Sub 排序_选区按列随机排序()
    Dim rng As Range
    Dim m, n
    On Error Resume Next
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Count = 1 Then '若选取的表格数为1
        MsgBox "请选择多个表格", vbExclamation, "提示"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    Set rng = Selection
    m = rng.End(4).Column - rng.Column + 1
    n = rng.End(4).Row - rng.Row + 1
    Set arr = rng.Resize(m, n)
    Randomize Timer
    For j = 1 To UBound(arr)
        For i = 1 To UBound(arr, 2) - 1
            R = Int(Rnd * (n - i + 1)) + i '随机排序
            '开始调换数据
            t = arr(R, 1)
            arr(R, 1) = arr(i, 1)
            arr(i, 1) = t
        Next
        Selection = arr
    Next
    Application.ScreenUpdating = True
End Sub

zjdh

Sub 排序_选区按列随机排序()
    On Error Resume Next
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Count = 1 Then '若选取的表格数为1
        MsgBox "请选择多个表格", vbExclamation, "提示"
        Exit Sub
    End If
    Application.ScreenUpdating = False
    arr = Selection
    Randomize Timer
    For J = 1 To UBound(arr, 2)
        For i = 1 To UBound(arr)
            R = Int(Rnd * UBound(arr)) + 1 '随机排序
            t = arr(R, J)
            arr(R, J) = arr(i, J)
            arr(i, J) = t
        Next
        Selection = arr
    Next
    Application.ScreenUpdating = True
End Sub

hasyh2008

Sub 随机排序()
   On Error Resume Next
    If TypeName(Selection) <> "Range" Then Exit Sub
    If Selection.Rows.Count = 1 Then '若选取的表格数为1
        MsgBox "请选择多行！", vbExclamation, "提示"
        Exit Sub
    End If
Dim Arr(), I%, Brr, Rc%
  Arr = Selection
  Rc = UBound(Arr)
  With Selection
    For I = 1 To UBound(Arr, 2)
      Brr = .Range(Cells(1, I), Cells(Rc, I))
      .Range(Cells(1, I), Cells(Rc, I)) = sortarrbyrnd(Brr)
    Next I
  End With
End Sub


Public Function sortarrbyrnd(Arr)
  Rem 数组随机排序函数
  Dim r, c, I, ii, Brr(), tmp1, tmp2, tmparr
  Randomize
  If LBound(Arr) = 0 Then '一维数组随机排序
      ReDim Brr(0 To UBound(Arr))
      For I = 0 To UBound(Brr) '将随机值写入辅助数组BRR，作为排序依据
          Brr(I) = Rnd
      Next
      For I = 0 To UBound(Brr) - 1
          For ii = I + 1 To UBound(Brr)
              If Brr(ii) < Brr(I) Then
                  tmp1 = Brr(I): Brr(I) = Brr(ii): Brr(ii) = tmp1
                  tmp2 = Arr(I): Arr(I) = Arr(ii): Arr(ii) = tmp2
              End If
          Next
      Next
  Else '二维数组随机排序
      ReDim Brr(1 To UBound(Arr))
      ReDim tmparr(1 To UBound(Arr, 2))
      For I = 1 To UBound(Brr)
          Brr(I) = Rnd
      Next
      For I = 1 To UBound(Brr) - 1
          For ii = I + 1 To UBound(Brr)
              If Brr(ii) < Brr(I) Then
                  tmp1 = Brr(I): Brr(I) = Brr(ii): Brr(ii) = tmp1
                  For c = 1 To UBound(Arr, 2): tmparr(c) = Arr(I, c): Next
                  For c = 1 To UBound(Arr, 2): Arr(I, c) = Arr(ii, c): Next
                  For c = 1 To UBound(Arr, 2): Arr(ii, c) = tmparr(c): Next
              End If
          Next
       Next
  End If
  sortarrbyrnd = Arr
End Function

荒野孤行

hasyh2008 发表于 2022-5-18 22:47
Sub 随机排序()
   On Error Resume Next
    If TypeName(Selection)  "Range" Then Exit Sub

这个也挺不错的，不同的思路体现不同的算法。

hasyh2008

zjdh 发表于 2022-5-18 21:42
Sub 排序_选区按列随机排序()
    On Error Resume Next
    If TypeName(Selection)  "Range" Then Exit ...

学习了！！