Option Explicit
Sub s3_lay_ten_ngay() '20/4/2022 tu viet
Application.ScreenUpdating = False
Dim arr, cell As Range
Dim lr&, i&, dk$, c&, c2&
Dim dic As Object: Set dic = CreateObject("Scripting.Dictionary")
Dim dic2 As Object: Set dic2 = CreateObject("Scripting.Dictionary")
dic2.CompareMode = TextCompare
With Sheet2
.AutoFilterMode = False
lr = .Range("F" & Rows.Count).End(xlUp).Row
arr = .Range("F9:M" & lr).Value2
dk = .Range("P3").Value
End With
For i = 1 To UBound(arr)
If arr(i, 6) = dk Then
If Not dic.Exists(arr(i, 1)) Then
dic.Add arr(i, 1), ""
End If
If Not dic2.Exists(arr(i, 3)) Then
dic2.Add arr(i, 3), ""
End If
End If
Next i
c = dic.Count
c2 = dic2.Count
If c2 = 0 Then Exit Sub
i = 0
With Sheet3
.Range(.Cells(10, 5), .Cells(10, 5 + c2)).EntireColumn.Hidden = False
.Range(.Cells(10, 5), .Cells(10, 5 + c2)).ClearContents
For Each cell In .Range("F10").Resize(, c2 * 2 - 1)
i = i + 1
If WorksheetFunction.IsOdd(i) Then cell.Value = dic2.Keys()(Int((i - 1) / 2))
Next
.Range(.Cells(11, 5), .Cells(11 + c, 5)).EntireRow.Hidden = False
.Range("E11:E" & 10 + c).ClearContents
.Range("E11").Resize(c).Value = Application.WorksheetFunction.Transpose(dic.Keys)
.Range("E11:E" & 10 + c).Sort .Range("E10"), xlAscending
.Range(.Cells(10, 6 + c2 * 2), .Cells(10, 52)).EntireColumn.Hidden = True
.Range(.Cells(11 + c, 5), .Cells(400, 5)).EntireRow.Hidden = True
End With
Application.ScreenUpdating = True
End Sub