[已解决]按类随机排序

abc153

按类随机排序.zip (2.47 KB, 下载次数: 15)

2015-4-21 13:54 上传

点击文件名下载附件
谢谢大家！

最佳答案

月排行榜 / 总排行榜

wcymiss

2015-4-23 12:58

请楼主测试：结果放在sheet2表中了：

1. Option Explicit
   
2. 
   
3. Sub Main()
   
4.     Dim arrData()
   
5.     Dim i As Long
   
6.     Dim startRow As Long
   
7.     Dim endRow As Long
   
8.    
   
9.     With Sheet1
   
10.         arrData = .Range("D5:I" & .Cells(.Rows.Count, "D").End(xlUp).Row + 1).Value
    
11.     End With
    
12.    
    
13.     startRow = 1
    
14.     For i = 2 To UBound(arrData)
    
15.         If arrData(i, 1) <> arrData(i - 1, 1) Then
    
16.             endRow = i - 1
    
17.             Call MySort(arrData, startRow, endRow, 6)
    
18.             startRow = i
    
19.         End If
    
20.     Next
    
21.    
    
22.     Sheet2.Cells.Clear
    
23.     Sheet2.Range("a1").Resize(UBound(arrData), UBound(arrData, 2)).Value = arrData
    
24. End Sub
    
25. 
    
26. Sub MySort(arrData, startRow As Long, endRow As Long, KeyColumn As Long)
    
27.     Dim i As Long
    
28.     Dim j As Long
    
29.     Dim RandNum As Long
    
30.    
    
31.     '洗牌随机
    
32.     Randomize
    
33.     For i = endRow To startRow Step -1
    
34.         RandNum = Int(Rnd * (i - startRow + 1) + startRow)
    
35.         Call Exchange(arrData, RandNum, i)
    
36.     Next
    
37.    
    
38.     '顺序倒序选择交换
    
39.     '顺序
    
40.     For i = startRow + 1 To endRow - 1
    
41.         If arrData(i, KeyColumn) = arrData(i - 1, KeyColumn) Then
    
42.             For j = i + 1 To endRow
    
43.                 If arrData(j, KeyColumn) <> arrData(i, KeyColumn) Then
    
44.                     Call Exchange(arrData, j, i)
    
45.                     Exit For
    
46.                 End If
    
47.             Next
    
48.         End If
    
49.     Next
    
50.    
    
51.     '倒序
    
52.     For i = endRow - 1 To startRow + 1 Step -1
    
53.         If arrData(i, KeyColumn) = arrData(i + 1, KeyColumn) Then
    
54.             For j = i - 1 To startRow Step -1
    
55.                 If arrData(j, KeyColumn) <> arrData(i, KeyColumn) Then
    
56.                     Call Exchange(arrData, j, i)
    
57.                     Exit For
    
58.                 End If
    
59.             Next
    
60.         End If
    
61.     Next
    
62. End Sub
    
63. 
    
64. Sub Exchange(arrData, row1 As Long, row2 As Long)
    
65.     Dim Temp
    
66.     Dim j As Long
    
67.     For j = 1 To UBound(arrData, 2)
    
68.         Temp = arrData(row1, j)
    
69.         arrData(row1, j) = arrData(row2, j)
    
70.         arrData(row2, j) = Temp
    
71.     Next
    
72. End Sub

复制代码

跳转到最佳答案楼层

dsmch

1. Sub Macro1()
   
2. Dim arr, brr, crr, d, i&, j&, k%, n&, s&, y&
   
3. Set d = CreateObject("scripting.dictionary")
   
4. arr = Range("d5:i" & Range("d65536").End(xlUp).Row + 1)
   
5. n = 1
   
6. For i = 2 To UBound(arr)
   
7.     If arr(i, 1) <> arr(n, 1) Then d(arr(i - 1, 1)) = n + 4 & "," & i + 3: n = i
   
8. Next
   
9. a = d.keys: b = d.items
   
10. For i = 0 To d.Count - 1
    
11.     x = Split(b(i), ",")
    
12.     brr = Range("d" & Val(x(0)) & ":i" & Val(x(1)))
    
13.     ReDim crr(1 To UBound(brr), 1 To UBound(brr, 2))
    
14.     n = UBound(brr)
    
15.     For j = 1 To n
    
16. 100:
    
17.         s = n - j + 1
    
18.         y = Int(Rnd * s + 1)
    
19.         If j > 1 Then
    
20.             If crr(j - 1, 6) = brr(y, 6) Then GoTo 100
    
21.         End If
    
22.         For k = 1 To UBound(brr, 2)
    
23.             crr(j, k) = brr(y, k)
    
24.             brr(y, k) = brr(s, k)
    
25.         Next
    
26.     Next
    
27.     Cells(Val(x(0)), "k").Resize(UBound(crr), UBound(crr, 2)) = crr
    
28. Next
    
29. End Sub

复制代码

dsmch

遇到死循环时（如随机排序，最后两人都是一班），按ESC强行中断代码

孙冰杉

如果班级相同，可多运行一次代码，楼主要求随机排序的 只要保证排序的班级错开就好了

grf1973

防死机代码

1. Sub tt()
   
2.     arr = [d4:i23]
   
3.     c = UBound(arr, 2)
   
4.     Randomize
   
5. bb:
   
6.     t1 = Timer
   
7.     r = UBound(arr)
   
8.     brr = arr
   
9.     For i = 2 To UBound(arr)
   
10. aa:
    
11.         p = Int((r - 1) * Rnd + 2)
    
12.         If arr(p, 6) <> brr(i - 1, 6) Then
    
13.             For j = 1 To c
    
14.                 brr(i, j) = arr(p, j)
    
15.                 arr(p, j) = arr(r, j)
    
16.             Next
    
17.             r = r - 1
    
18.         Else
    
19.             If Timer - t1 > 1 Then
    
20.                 s = s + 1
    
21.                 If s > 3 Then MsgBox "请重新点击": Exit Sub
    
22.                 GoTo bb
    
23.             End If
    
24.             GoTo aa
    
25.         End If
    
26.     Next
    
27.     [k4].Resize(UBound(brr), UBound(brr, 2)) = brr
    
28. End Sub
    

复制代码

abc153

谢谢各位老师，您们写的代码都很卡，有时还无法运行！

上清宫主

试试这个，应该不会卡：
注意：用了字典，请自行引用；J列做了辅助列，故J列中不要有内容
Sub test()
Dim d1 As New Dictionary, d2 As New Dictionary, ar1(), ar2()
i1% = [g65536].End(3).Row
If i1 < 6 Then Exit Sub
[j5].Resize(i1 - 4) = "=rand()"
Range("g4").Resize(i1 - 3, 4).Sort [i4], , [j4], , , , , xlYes
[j5].Resize(i1 - 4).ClearContents
ar1 = Range("g5").Resize(i1 - 4, 3).Value
ReDim ar2(1 To i1 - 4, 1 To 3)
For i1 = 1 To UBound(ar1)
    d1(ar1(i1, 3)) = i1
    d2(ar1(i1, 3)) = d2(ar1(i1, 3)) + 1
Next
For i1 = 1 To UBound(ar1)
    maxr% = 0
    For Each stmp In d1.Keys
        If bj$ <> stmp Then If maxr% < d2(stmp) Then maxr = d2(stmp): stmp2$ = stmp
    Next
    If maxr Then bj = stmp2
    r = r% + 1
    ar2(r, 1) = ar1(d1(bj), 1)
    ar2(r, 2) = ar1(d1(bj), 2)
    ar2(r, 3) = ar1(d1(bj), 3)
    d1(bj) = d1(bj) - 1
    d2(bj) = d2(bj) - 1
Next
[m5].Resize(UBound(ar2), 3) = ar2
End Sub

wcymiss

请楼主测试：结果放在sheet2表中了：

1. Option Explicit
   
2. 
   
3. Sub Main()
   
4.     Dim arrData()
   
5.     Dim i As Long
   
6.     Dim startRow As Long
   
7.     Dim endRow As Long
   
8.    
   
9.     With Sheet1
   
10.         arrData = .Range("D5:I" & .Cells(.Rows.Count, "D").End(xlUp).Row + 1).Value
    
11.     End With
    
12.    
    
13.     startRow = 1
    
14.     For i = 2 To UBound(arrData)
    
15.         If arrData(i, 1) <> arrData(i - 1, 1) Then
    
16.             endRow = i - 1
    
17.             Call MySort(arrData, startRow, endRow, 6)
    
18.             startRow = i
    
19.         End If
    
20.     Next
    
21.    
    
22.     Sheet2.Cells.Clear
    
23.     Sheet2.Range("a1").Resize(UBound(arrData), UBound(arrData, 2)).Value = arrData
    
24. End Sub
    
25. 
    
26. Sub MySort(arrData, startRow As Long, endRow As Long, KeyColumn As Long)
    
27.     Dim i As Long
    
28.     Dim j As Long
    
29.     Dim RandNum As Long
    
30.    
    
31.     '洗牌随机
    
32.     Randomize
    
33.     For i = endRow To startRow Step -1
    
34.         RandNum = Int(Rnd * (i - startRow + 1) + startRow)
    
35.         Call Exchange(arrData, RandNum, i)
    
36.     Next
    
37.    
    
38.     '顺序倒序选择交换
    
39.     '顺序
    
40.     For i = startRow + 1 To endRow - 1
    
41.         If arrData(i, KeyColumn) = arrData(i - 1, KeyColumn) Then
    
42.             For j = i + 1 To endRow
    
43.                 If arrData(j, KeyColumn) <> arrData(i, KeyColumn) Then
    
44.                     Call Exchange(arrData, j, i)
    
45.                     Exit For
    
46.                 End If
    
47.             Next
    
48.         End If
    
49.     Next
    
50.    
    
51.     '倒序
    
52.     For i = endRow - 1 To startRow + 1 Step -1
    
53.         If arrData(i, KeyColumn) = arrData(i + 1, KeyColumn) Then
    
54.             For j = i - 1 To startRow Step -1
    
55.                 If arrData(j, KeyColumn) <> arrData(i, KeyColumn) Then
    
56.                     Call Exchange(arrData, j, i)
    
57.                     Exit For
    
58.                 End If
    
59.             Next
    
60.         End If
    
61.     Next
    
62. End Sub
    
63. 
    
64. Sub Exchange(arrData, row1 As Long, row2 As Long)
    
65.     Dim Temp
    
66.     Dim j As Long
    
67.     For j = 1 To UBound(arrData, 2)
    
68.         Temp = arrData(row1, j)
    
69.         arrData(row1, j) = arrData(row2, j)
    
70.         arrData(row2, j) = Temp
    
71.     Next
    
72. End Sub

复制代码