Option Explicit
Private Function UniqueRandomNum(Bottom As Long, Top As Long, Amount As Long)
On Error Resume Next
If Amount > Top - Bottom + 1 Then Amount = Top - Bottom + 1
With CreateObject("Scripting.Dictionary")
Do
.Add Int(Rnd() * (Top - Bottom + 1)) + Bottom, ""
Loop Until .Count = Amount
UniqueRandomNum = .Keys
End With
End Function
Private Function LayDS(Rng As Range, Optional aCot = 5, Optional LOAI As String = "Trung bình")
Dim aRow%, aCol%, i&, j&, k&
Dim Arr, TempDes, Des, TT
aRow = Rng.Rows.Count: aCol = Rng.Columns.Count
Arr = Rng.Value
aRow = UBound(Arr, 1): aCol = UBound(Arr, 2)
ReDim TempDes(1 To aRow, 1 To aCol + 2)
For i = 1 To aRow
If Arr(i, aCot) = LOAI Then
k = k + 1: TempDes(k, 1) = k
For j = 1 To aCol
TempDes(k, j + 1) = Arr(i, j)
Next j
End If
Next i
If k = 0 Then Exit Function
TT = UniqueRandomNum(1, k, k)
ReDim Des(1 To k, 1 To aCol + 2)
aCol = UBound(TempDes, 2)
For i = 1 To k
For j = 1 To aCol
If j = aCol Then
Des(i, j) = TT(i - 1)
Else
Des(i, j) = TempDes(i, j)
End If
Next j
Next i
LayDS = Des
End Function
Private Function WorksheetExists(shtName As String, Optional wb As Workbook) As Boolean
Dim sht As Worksheet
If wb Is Nothing Then Set wb = ThisWorkbook
On Error Resume Next
Set sht = wb.Sheets(shtName)
On Error GoTo 0
WorksheetExists = Not sht Is Nothing
End Function
Private Function TachDS(DS, SL As Integer, aIndex As Integer, TT As Integer)
Dim i%, j%, k%, Max%, Des
k = 0: Max = SL + aIndex - 1
If Max > UBound(DS, 1) Then Max = UBound(DS, 1)
ReDim Des(1 To (Max - aIndex + 1), 1 To UBound(DS, 2))
For i = aIndex To Max
k = k + 1: Des(k, 1) = TT + k - 1
For j = 2 To UBound(DS, 2)
Des(k, j) = DS(CInt(DS(i, 7)), j - 1)
Next j
Next i
TachDS = Des
End Function
Sub ChiaLop()
Const SOLOP = 7
Dim sh As Worksheet, DS(1 To 3) As Variant, TENLOP, LOAI, i%, j%
Dim Rng As Range, SoHS%, ViTri%, TT%, TTLoai%, aStep%
Dim Tach_DS
TENLOP = Array("LOP1", "LOP2", "LOP3", "LOP4", "LOP5", "LOP6", "LOP7")
LOAI = Array("Gi" & ChrW(7887) & "i", "Khá", "Trung bình")
Set Rng = Sheet1.Range("C10:G" & Sheet1.Range("G10000").End(xlUp).Row)
SoHS = Rng.Rows.Count \ SOLOP
For i = 1 To 3
DS(i) = LayDS(Rng, , CStr(LOAI(i - 1)))
Next i
For i = LBound(TENLOP) To UBound(TENLOP)
If WorksheetExists(CStr(TENLOP(i))) Then
Application.DisplayAlerts = False
ThisWorkbook.Sheets(CStr(TENLOP(i))).Delete
Application.DisplayAlerts = True
End If
ThisWorkbook.Sheets("Sheet1").Copy after:=Sheets(Sheets.Count)
Set sh = ThisWorkbook.Sheets(Sheets.Count)
sh.Name = CStr(TENLOP(i))
sh.Range("A10:G10").Resize(Rng.Rows.Count).ClearContents
TT = 1
For j = 1 To 3
ViTri = UBound(DS(j), 1) \ SOLOP
TTLoai = ViTri: aStep = ViTri
If UBound(DS(j), 1) Mod SOLOP > i Then
ViTri = i * (ViTri + 1) + 1
TTLoai = TTLoai + 1
Else
ViTri = i * (ViTri + 1)
End If
Tach_DS = TachDS(DS(j), TTLoai, ViTri, TT)
If IsArray(Tach_DS) Then
sh.Range("A9:G10").Offset(TT).Resize(UBound(Tach_DS, 1)).Value = Tach_DS
TT = TT + UBound(Tach_DS, 1)
End If
Next j
Next i
End Sub
