Sub GPE()
Dim sarr(), Res(), tmp As Variant
Dim i As Long, j As Long, sRow As Long
Dim iMax As Long, ik As Long, jMin As Long, jk As Long, jCol As Long
Const S = 6 'So lan 1 Cot
Const sCol = 20 'So cot
sarr = Range("A3:B22").Value
sRow = UBound(sarr)
For i = 1 To sRow
If sarr(i, 2) > sCol Then MsgBox ("So lan Lap sai"): Exit Sub
ik = ik + sarr(i, 2)
Next i
If ik <> S * sCol Then MsgBox ("So lan Lap sai"): Exit Sub
ReDim Res(1 To sRow + 1, 1 To sCol)
For i = 1 To sRow
iMax = 0
For k = 1 To sRow
If iMax < sarr(k, 2) Then iMax = sarr(k, 2): ik = k
Next k
If iMax > 0 Then
sarr(ik, 2) = 0
For j = 1 To iMax
tmp = UniqueRand(sCol)
jMin = 100
For k = 1 To sCol
jk = tmp(k)
If jMin > Res(sRow + 1, jk) Then jMin = Res(sRow + 1, jk): jCol = jk
Next k
Res(sRow + 1, jCol) = Res(sRow + 1, jCol) + 1
Res(ik, jCol) = sarr(ik, 1)
Next j
End If
Next i
Range("D3").Resize(sRow, sCol) = Res
End Sub
Private Function UniqueRand(ByVal N As Long) As Variant
Dim Arr() As Long, i As Long, RndNum As Long, tmp As Long
ReDim Arr(1 To N)
Randomize
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
