时间:2020-02-10  来源:百度经验  作者:南霸天mxw  阅读:6

在日常举行的体育比赛中,分组是比较难办的事情,因为牵扯到天时地利人和的因素,如果不能合适的分好组,会落得很多抱怨,这里我们通过VBA代码来实现比赛的随机自动分组,这样就避免了一些不必要的麻烦。

EXCEL技巧——VBA自动给体育比赛分组

新建一张表格,在表格中输入以下内容:  “姓名      性别      班级      往届成绩”,如图所示。

EXCEL技巧——VBA自动给体育比赛分组

单击菜单栏“开发工具”——Visualbasic,打开VBA编辑器,我们将在其中输入代码。

单击菜单栏“插入”——模块,打开代码编辑框,现在我们就可以在其中插入代码来了。

现在我们来插入代码:Option ExplicitSub 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    NextEnd SubFunction 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 = arrEnd Function

EXCEL技巧——VBA自动给体育比赛分组

现在回到EXCEL表格,单击“开发工具”——插入——按钮,拖住十字箭头画出一个矩形按钮,弹出对话框。选择宏“fenzu”,单击确定。

现在右键单击按钮,选择“编辑文字”,现在吧按钮名称改为“自动分组”。

现在单击自动分组按钮,弹出对话框“请输入分组数”,输入“3”,单击确定,我们就看到分好的组了。

Top