Function UniqueList(ParamArray sArray())
Dim Item, tmpArr, SubArr
On Error Resume Next
With CreateObject("Scripting.Dictionary")
For Each SubArr In sArray
tmpArr = SubArr
If TypeName(tmpArr) <> "Variant()" Then
If tmpArr <> "" Then .Add tmpArr, ""
Else
For Each Item In tmpArr
If Item <> "" Then
If Not .Exists(Item) Then .Add Item, ""
End If
Next
End If
Next
If .Count Then UniqueList = .Keys
End With
End Function
Sub DUYNHAT()
Dim Arr, tmpArr, I As Long
Dim COT As Byte
Dim K As Byte
COT = 5
Sheet1.Range("F3:Z65000").ClearContents
tmpArr = UniqueList(Sheet1.Range("B3:B65000"))
If IsArray(tmpArr) Then
ReDim Arr(1 To UBound(tmpArr) + 1, 1 To 1)
For I = 0 To UBound(tmpArr)
Arr(I + 1, 1) = tmpArr(I)
Next
End If
If (I > 0) Then
For K = 1 To I
Call DULIEU(Arr(K, 1), COT)
COT = COT + 4
Next K
End If
End Sub
Sub DULIEU(TEMP, COT As Byte)
Dim Rngs(), Arr(), I As Long, K As Long
On Error Resume Next
With Sheet1
Rngs = .Range(.[A3], .[A65000].End(xlUp)).Resize(, 4).Value
End With
ReDim Arr(1 To UBound(Rngs, 1), 1 To 2)
For I = 1 To UBound(Rngs, 1)
If Rngs(I, 2) = TEMP Then
K = K + 1
Arr(K, 1) = Rngs(I, 2)
Arr(K, 2) = Rngs(I, 3)
End If
Next I
If (K > 0) Then
Sheet1.Range(Cells(3, COT), Cells(3, COT)).Resize(K, 2).Value = Arr
End If
Sheet1.Select
Range(Cells(3, COT + 2), Cells(3, COT + 2)).Select
ActiveCell.FormulaR1C1 = "=COUNTIF(R3C[-1]:R" & K + 2 & "C[-1],"">=""&RC[-1])/" & K & ""
Range(Cells(3, COT + 2), Cells(3, COT + 2)).Select
Selection.Copy
Range(Cells(3, COT + 2), Cells(2 + K, COT + 2)).Select
Selection.PasteSpecial Paste:=xlPasteFormulas, Operation:=xlNone, _
SkipBlanks:=False, Transpose:=False
Application.CutCopyMode = False
End Sub
