Option Explicit
Option Compare Text
Dim arr(), aLop(), aBT(), res(), sRow&, n&
Sub xyz()
Dim aDB(), i&, j&, dt$
With Sheets("TachHoTen")
arr = .Range("I5:O" & .Range("F" & Rows.Count).End(xlUp).Row).Value
End With
sRow = UBound(arr)
ReDim res(1 To sRow, 1 To 1)
With Sheets("Chia")
aLop = .Range("B3:L3").Value
aBT = .Range("B5:L13").Value
aDB = .Range("B16:L20").Value
End With
n = 0
For i = 1 To UBound(aDB) 'Doi tuong dac biet
dt = Trim(aDB(i, 1))
Call Db(aDB, dt, i, 1, 7) 'xep Nu HS
Call Db(aDB, dt, i, 0, 7) 'xep HS
Next i
For i = 1 To UBound(aBT) 'Doi tuong bình thuong
dt = Trim(aBT(i, 1))
Call Db(aBT, dt, i, 1, 4) 'xep Nu HS
Call Db(aBT, dt, i, 0, 4) 'xep HS
Next i
Sheets("TachHoTen").Range("Q5").Resize(sRow, 1).ClearContents
If n = sRow Then Sheets("TachHoTen").Range("Q5").Resize(sRow, 1) = res
End Sub
Sub Db(aT, dt, i, ByVal d&, ByVal col&)
Dim S, a, hs$, r&, r2&, j&, c&, k&, id&
For r = 1 To sRow
If Trim(arr(r, col)) = dt Then
If d = 0 Or arr(r, 1) = 1 Then hs = hs & "," & r
End If
Next r
If hs <> Empty Then
S = Split(hs, ",")
a = UniqueRand(UBound(S))
For j = 4 + d To UBound(aT, 2) Step 2
If aT(i, j) > 0 Then
For c = 1 To aT(i, j)
If k < UBound(S) Then k = k + 1 Else k = 1
id = S(a(k))
If col = 7 Then 'Doi tuong dac biet
For r2 = 1 To UBound(aBT)
If aBT(r2, 1) = arr(id, 4) Then
If aBT(r2, j) > 0 Then
n = n + 1
res(id, 1) = aLop(1, j - d)
arr(id, col) = Empty: arr(id, 4) = Empty
aBT(r2, j) = aBT(r2, j) - 1
If d = 1 Then 'HS Nu
aT(i, j - 1) = aT(i, j - 1) - 1
aBT(r2, j - 1) = aBT(r2, j - 1) - 1
End If
Exit For
End If
End If
Next r2
Else 'Doi tuong bình thuong
If aBT(i, j) > 0 Then
aBT(i, j) = aBT(i, j) - 1
If d = 1 Then aBT(i, j - 1) = aBT(i, j - 1) - 1 'HS Nu
arr(id, 4) = Empty
res(id, 1) = aLop(1, j - d)
n = n + 1
End If
End If
Next c
End If
Next j
End If
End Sub
Private Function UniqueRand(ByVal n As Long) As Variant
Dim arr() As Long, i&, RndNum&, tmp&
ReDim arr(1 To n)
For i = 1 To n
RndNum = Int(n * Rnd() + 1)
If arr(RndNum) = 0 Then tmp = RndNum Else tmp = arr(RndNum)
If arr(n) = 0 Then arr(RndNum) = n Else arr(RndNum) = arr(n)
arr(n) = tmp
n = n - 1
Next i
UniqueRand = arr
End Function
13 và C16
