EXCEL技巧——VBA自动给体育比赛分组
1、 新建一张表格，在表格中输入以下内容：
“姓名 性别 班级 往届成绩”，如图所示。
2、 单击菜单栏“开发工具”——Visualbasic，打开VBA编辑器，我们将在其中输入代码。
3、 单击菜单栏“插入”——模块，打开代码编辑框，现在我们就可以在其中插入代码来了。
4、 现在我们来插入代码：
Option Explicit
Sub FenZu()
Dim arr, arr1(), arr2(), arr11, arr22, i&, j&, m&, n&, arrD(), p1
Dim rng As Range, p As Long, zs(), rs As Long, d, darr1, darr2, str As String
Application.ScreenUpdating = False
Set d = CreateObject("Scripting.Dictionary")
arr = Sheets("sheet1").Range("a3:d15")
str = "请输入分组数"
line1:
p1 = Application.InputBox(prompt:=str, Type:=1)
If p1 = False Then Exit Sub
If Int(p1) <> p1 Or p1 > UBound(arr) / 2 Or p1 < 2 Then
str = "分组数不合法，请重新输入！"
GoTo line1
End If
p = p1
rs = -Int(-UBound(arr) / p)
ReDim zs(1 To p)
For i = 1 To p
zs(i) = rs
Next
For i = 1 To rs * p - UBound(arr)
zs(i) = zs(i) - 1
Next
ReDim arrD(1 To UBound(arr), 1 To 5)
ReDim arr1(1 To UBound(arr) - p): ReDim arr2(1 To p)
arr11 = dhrand(1, UBound(arr) - p): arr22 = dhrand(1, p)
For i = 1 To UBound(arr)
If arr(i, 4) = "" Then
m = m + 1
If m <= UBound(arr1) Then
arr1(m) = i
Else
n = n + 1: arr2(n) = i
End If
Else
n = n + 1
If n <= UBound(arr2) Then
arr2(n) = i
Else
m = m + 1: arr1(m) = i
End If
End If
Next
m = 1
For i = 1 To p
d(m) = zs(i): m = m + zs(i)
Next
m = 0: n = 0
For i = 1 To UBound(arrD)
If d.exists(i) Then
m = m + 1
For j = 2 To 5
arrD(i, j) = arr(arr2(arr22(m)), j - 1)
Next
Else
n = n + 1
For j = 2 To 5
arrD(i, j) = arr(arr1(arr11(n)), j - 1)
Next
End If
Next
With Sheets(1)
.Range("3:10000").Clear
.Range("b3").Resize(UBound(arrD), UBound(arrD, 2)) = arrD
End With
darr1 = d.keys: darr2 = d.items
For i = 1 To p
Set rng = Sheets(1).Range("b" & darr1(i - 1) + 2).Resize(darr2(i - 1), 5)
rng.BorderAround ColorIndex:=5, Weight:=xlThick
rng.Cells(1) = "第" & Format(i, "00") & "组"
rng.Columns(1).Merge
Next
End Sub
Function dhrand(il As Long, ih As Long) As Variant
Dim aintValues() As Long, arr() As Long, intI&, intP&
ReDim aintValues(1 To ih - il + 1)
ReDim arr(1 To ih - il + 1)
For intI = il To ih
aintValues(intI - il + 1) = intI
Next intI
For intI = ih - il + 1 To 1 Step -1
intP = Int(Rnd * intI) + 1
arr(intI) = aintValues(intP)
aintValues(intP) = aintValues(intI)
Next intI
dhrand = arr
End Function
5、 现在回到EXCEL表格，单击“开发工具”——插入——按钮，拖住十字箭头画出一个矩形按钮，弹出对话框。选择宏“fenzu”，单击确定。
6、 现在右键单击按钮，选择“编辑文字”，现在吧按钮名称改为“自动分组”。
7、 现在单击自动分组按钮，弹出对话框“请输入分组数”，输入“3”，单击确定，我们就看到分好的组了。
