Option Explicit
Sub XYZ()
Dim sh As Worksheet
Dim arr(), aDiem, aTK(), a, b, c, d, res()
Dim soHS&, soNhom&, N&, i&, r&, j&, k&, gt&, le&
Dim soNu&, nMin&, nMax&, t&, hl&, iDC&, tmp$
Set sh = Sheets("8a2")
arr = sh.Range("D2", sh.Range("E" & Rows.Count).End(xlUp)).Value
soHS = UBound(arr)
On Error Resume Next
N = InputBox("Hay nhap so hoc sinh cua 1 nhom vào o bên duoi", "CHIA HOC SINH THEO NHOM")
If N = 0 Then
MsgBox " Ban phai nhap sô hoc sinh cua 1 nhóm": Exit Sub
End If
If N > soHS Then N = soHS
soNhom = Int(soHS / N) 'Phan HS thanh soNhom NHOM
On Error GoTo 0
Randomize
ReDim res(1 To soHS, 1 To 2)
ReDim aTK(1 To soNhom, 0 To 6)
ReDim a(1 To 8) 'Chia HS thanh 8 nhom theo Gioi Tinh va Diem
ReDim d(1 To 8) 'Hoc luc
aDiem = Array(0, 8, 7.5, 6.5, 5)
For i = 1 To soHS 'xep thu tu HS theo GT va Diem
If Len(arr(i, 1)) = 2 Then
gt = 0
soNu = soNu + 1
Else
gt = 1
End If
For j = 1 To 4
If arr(i, 2) >= aDiem(j) Then
a(j * 2 - gt) = a(j * 2 - gt) & "," & i
d(j * 2 - gt) = d(j * 2 - gt) & "," & j
Exit For
End If
Next j
Next i
a = Split(Join(a, ""), ",") 'Mang HS xep thu tu theo GT va Diem
d = Split(Join(d, ""), ",") 'Mang Loai Hoc luc
nMin = Int(soNu / soNhom) 'So nu it nhat trong 1 nhom
If nMin * soNhom = soNu Then nMax = nMin Else nMax = nMin + 1 'So nu nhieu nhat trong 1 nhom
le = soHS - soNhom * N
If le > 0 Then 'Chon ngau nhien HS le nhom
Call TaoMangNgauNhien(c, soHS)
Call TaoMangNgauNhien(b, soNhom)
For j = 1 To le
r = c(j)
res(a(r), 1) = b(j)
res(a(r), 2) = d(r)
If Len(arr(a(r), 1)) = 2 Then aTK(b(j), 2) = aTK(b(j), 2) + 1
a(r) = Empty
Next j
End If
Do 'Chon ngau nhien HS phan vào các nhóm
Call TaoMangNgauNhien(b, soNhom)
For j = 1 To soNhom
k = k + 1
If k > soHS Then Exit Do
If a(k) <> Empty Then
res(a(k), 1) = b(j)
res(a(k), 2) = d(k)
If Len(arr(a(k), 1)) = 2 Then aTK(b(j), 2) = aTK(b(j), 2) + 1
Else
j = j - 1
End If
Next j
Loop
DieuChinhTiep:
For i = 1 To soNhom 'Dieu chinh so nu
If aTK(i, 2) < nMin Or aTK(i, 2) > nMax Then 'Nhom dieu chinh Tang HS Nu
t = soHS + 1
For r = 1 To soNhom
If t > aTK(r, 2) Then
t = aTK(r, 2)
iDC = r 'nhom co so Nu it nhat
End If
Next r
t = 0
For r = 1 To soNhom
If t < aTK(r, 2) Then
t = aTK(r, 2)
k = r 'nhom co so nu nhieu nhat
End If
Next r
tmp = Empty
TroLai:
For r = 1 To soHS
If res(r, 1) = i And Len(arr(r, 1)) <> 2 Then 'Nhom dieu chinh Tang HS Nu và HS Nam
hl = res(r, 2) 'Hoc luc
If InStr(1, tmp, hl) = 0 Then
tmp = tmp & hl
For c = 1 To soHS
If Len(arr(c, 1)) = 2 And res(c, 1) = k And res(c, 2) = hl Then 'HS Nu và nhom co Nu nhieu nhat và cung Hoc luc
t = res(c, 1)
res(c, 1) = res(r, 1)
res(r, 1) = t
aTK(iDC, 2) = aTK(iDC, 2) + 1
aTK(t, 2) = aTK(t, 2) - 1
GoTo DieuChinhTiep
End If
Next c
If c > soHS Then GoTo TroLai
End If
End If
Next r
End If
Next i
sh.Range("F2").Resize(soHS, 2) = res
Call ThongKe(sh, res, aTK, soHS) 'Bang Thong ke ket qua phan nhom
End Sub
Sub ThongKe(sh, res, aTK, soHS)
'aTK co 7 Cot:Nhom, So Hoc Sinh, So Nu, Hoc luc A, B, C, D
Dim i&, r&, c&
For i = 1 To soHS
r = res(i, 1)
c = res(i, 2) + 2
aTK(r, 1) = aTK(r, 1) + 1
aTK(r, c) = aTK(r, c) + 1
Next i
For i = 1 To UBound(aTK)
aTK(i, 0) = i
Next i
sh.Range("I2").Resize(soHS, 7).ClearContents
sh.Range("I2").Resize(UBound(aTK), 7) = aTK
End Sub
Sub TaoMangNgauNhien(aRnd, ByVal N)
Dim i&, t&, r&
ReDim aRnd(1 To N)
For i = 1 To N
r = Int(Rnd * N) + 1
If aRnd(r) = 0 Then t = r Else t = aRnd(r)
If aRnd(N) = 0 Then aRnd(r) = N Else aRnd(r) = aRnd(N)
aRnd(N) = t
N = N - 1
Next i
End Sub
vì trong thực tế không quan trọng lắm 
