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」，單擊確定，我們就看到分好的組了。