|
本帖最后由 hasyh2008 于 2022-5-19 09:08 编辑
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
|
|