VBA随机重新分班

laoau138

VBA随机重新分班

grf1973

1. Sub 分班()
   
2.     Dim L&, k%
   
3.     k = 8
   
4.     arr = [a1].CurrentRegion: L = UBound(arr)
   
5.     brr = arr
   
6.     ReDim crr(2 To L), drr(2 To L)      '生成随机乱序，放在drr
   
7.     For i = 2 To L: crr(i) = i: Next
   
8.     For i = 2 To L
   
9.         p = Int(Rnd * (L - 1) + 1) + 1
   
10.         drr(i) = crr(p)
    
11.         crr(p) = crr(L)
    
12.         L = L - 1
    
13.     Next
    
14.    
    
15.     Call 删除
    
16.     For i = 2 To UBound(arr)      '按drr取数
    
17.         p = drr(i)
    
18.         n = (i - 1) Mod k
    
19.         If n = 0 Then n = k
    
20.         For j = 1 To UBound(arr, 2)
    
21.             brr(n + 1, j) = arr(p, j)
    
22.         Next
    
23.         If n = k Or i = UBound(arr) Then
    
24.             Sheets.Add after:=Sheets(Sheets.Count)
    
25.             bj = bj + 1
    
26.             sx = UBound(arr) - 1 - (bj - 1) * k '剩下的人数
    
27.             ss = IIf(n = k, k, sx)  '每个班的人数（最后一个班有可能不是8人）
    
28.             With ActiveSheet
    
29.                 .Name = bj & "班"
    
30.                 .[a1].Resize(ss + 1, UBound(arr, 2)) = brr
    
31.             End With
    
32.         End If
    
33.     Next
    
34. End Sub
    
35. 
    
36. Sub 删除()
    
37.     Application.DisplayAlerts = False
    
38.     For Each sh In Worksheets
    
39.         If sh.Index > 1 Then sh.Delete
    
40.     Next
    
41.     Application.DisplayAlerts = True
    
42. End Sub

复制代码

grf1973

请看附件。

grf1973

用辅助列随机排序后分配。代码简单一点。

1. Sub 分班()
   
2.     Dim L&, k%, c%
   
3.     k = 8
   
4.     arr = [a1].CurrentRegion: L = UBound(arr): c = UBound(arr, 2)
   
5.     [d2].Resize(L - 1).Formula = "=rand()"   '辅助列
   
6.     [a2].Resize(L - 1, c + 1).Sort key1:=[d2]      '随机排序
   
7.     [d:d] = ""
   
8.    
   
9.     Call 删除
   
10.     For i = 2 To UBound(arr) Step k      '按drr取数
    
11.         Sheets.Add after:=Sheets(Sheets.Count)
    
12.         bj = bj + 1
    
13.         With ActiveSheet
    
14.             .Name = bj & "班"
    
15.             .[a1].Resize(1, c) = Sheets(1).[a1].Resize(1, c).Value
    
16.             .[a2].Resize(k, c) = Sheets(1).Cells(i, 1).Resize(k, c).Value
    
17.         End With
    
18.     Next
    
19.     Sheets(1).[a1].CurrentRegion = arr    '恢复原序
    
20. End Sub
    
21. 
    
22. Sub 删除()
    
23.     Application.DisplayAlerts = False
    
24.     For Each sh In Worksheets
    
25.         If sh.Index > 1 Then sh.Delete
    
26.     Next
    
27.     Application.DisplayAlerts = True
    
28. End Sub
    

复制代码

laoau138

grf1973 发表于 2017-1-6 10:37
请看附件。

grf1973  大侠是高手

laoau138

grf1973 发表于 2017-1-6 10:35

VBA蓝底单元格输入数字全排列   然后再容错

http://www.excelpx.com/thread-427027-1-1.html

雄鹰2013

Sub 随机分班()
Dim ar, br(), sht As Worksheet
Set d = CreateObject("scripting.dictionary")
Set dd = CreateObject("scripting.dictionary")
Sheet1.Activate
ar = [a1].CurrentRegion
x = 3
For i = 2 To UBound(ar)
n = Int(Rnd * x) + 1 'Rnd 函数返回小于 1 但大于或等于 0 的值。
d(n) = d(n) + 1
Do While d(n) > 8
   n = Int(Rnd * x) + 1 '
   d(n) = d(n) + 1
Loop
dd(n) = dd(n) & "," & i
Next i
Application.ScreenUpdating = False
For Each sht In Worksheets
    If sht.Name <> "题目要求" Then
    Application.DisplayAlerts = False
       sht.Delete
    Application.DisplayAlerts = True
    End If
Next sht
For Each k In dd.keys
    ReDim br(1 To UBound(ar), 1 To UBound(ar, 2))
    a = Split(dd(k), ",")
    For i = 1 To UBound(a)
        y = a(i)
        m = m + 1
        For j = 1 To UBound(ar, 2)
            br(m, j) = ar(y, j)
        Next j
    Next i
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = k & "班"
    [a1:c1] = Array("ID", "科目", "成绩")
    ActiveSheet.[a2].Resize(UBound(a) - 1, 3) = br
    m = 0
Next k
Sheet1.Activate
Application.ScreenUpdating = True
End Sub

laoau138

雄鹰2013 发表于 2018-6-27 16:29
Sub 随机分班()
Dim ar, br(), sht As Worksheet
Set d = CreateObject("scripting.dictionary")

正好论坛这几天可用了