Sub tuhocvba()
Dim i As Long, j As Long, cnt As Long
Dim n As Long
Dim rend As Long
Dim arr
Dim rng As Range
Dim r As Long, r1 As Long, c As Long
Dim myDic As Object
On Error Resume Next
With ThisWorkbook.Sheets(1)
n = .Cells(1, 3) 'C1
rend = .Cells(.Rows.Count, 1).End(3).Row
arr = .Range(.Cells(2, 1), .Cells(rend, 2)).Value
End With
On Error GoTo 0
If n <> 100 Then
MsgBox "Kiem tra gia tri o C1"
Exit Sub 'khong phai la 100 thi thoat
End If
If rend < 2 Then
MsgBox "Khong co du lieu tren cot A"
Exit Sub
End If
Set myDic = CreateObject("Scripting.Dictionary")
For i = LBound(arr, 1) To UBound(arr, 1) Step 1
If Not myDic.Exists(arr(i, 1)) Then
myDic.Add arr(i, 1), arr(i, 2)
Else
myDic.Item(arr(i, 1)) = myDic.Item(arr(i, 1)) + arr(i, 2)
End If
Next i
'Xep ngau nhien
arr = myDic.Keys
cnt = 0
On Error GoTo tiep
With ThisWorkbook.Sheets(2)
For i = LBound(arr) To UBound(arr) Step 1
For j = 1 To myDic.Item(arr(i)) Step 1
cnt = cnt + 1
.Cells(cnt, 1) = arr(i)
Next j
tiep:
Next i
On Error GoTo 0
If cnt = 0 Then Exit Sub
Call Randomize 'Reset ngau nhien
For i = 1 To cnt Step 1
.Cells(i, 2) = Rnd
Next i
Set rng = .Range(.Cells(1, 2), .Cells(cnt, 2))
For i = 1 To rng.Rows.Count
.Cells(i, 3) = WorksheetFunction.Rank(.Cells(i, 2), rng)
Next i
arr = .Range(.Cells(1, 1), .Cells(cnt, 3)).Value
End With
'Ghi ket qua:
With ThisWorkbook.Sheets(1)
For i = LBound(arr, 1) To UBound(arr, 1) Step 1
n = arr(i, 3)
c = n Mod 10
If c = 0 Then
r1 = n / 10
If r1 = 0 Then r1 = 1
Else
r1 = Int(n / 10) + 1
End If
r = r1 + 1
If c = 0 Then
c = 13
Else
c = c + 3
End If
.Cells(r, c) = arr(i, 1)
Next i
End With
End Sub