Option Explicit
Sub LocTKB()
Dim i&, j&, Lr&, R&, t&, k&
Dim Arr(), KQ(), TenGV(), Lop()
Dim Dic As Object, Key
Dim Ws As Worksheet, Sh As Worksheet
Set Sh = Sheets("Xep")
Set Ws = Sheets("TH")
Lr = Ws.Cells(10000, 3).End(xlUp).Row
TenGV = Ws.Range("C7:C" & Lr).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(TenGV)
Key = UCase(TenGV(i, 1))
If Not Dic.Exists(Key) Then t = t + 1: Dic.Add (Key), t
Next i
ReDim KQ(1 To t, 1 To 24)
Lr = Sh.Cells(10000, 2).End(xlUp).Row
Arr = Sh.Range("C6:Z" & Lr).Value
Lop = Sh.Range("C5:Z5").Value
For R = 1 To UBound(Arr) Step 4
For i = R To R + 3
For j = 2 To UBound(Arr, 2) Step 2
If Arr(i, j) <> Empty And Dic.Exists(UCase(Arr(i, j))) Then
k = Dic.Item(UCase(Arr(i, j)))
KQ(k, i) = Arr(i, j - 1) & "-" & Lop(1, j - 1)
End If
Next j
Next i
Next R
Ws.Range("D7").Resize(t, 24).ClearContents
Ws.Range("D7").Resize(t, 24) = KQ
Set Dic = Nothing
MsgBox "Thành công"
End Sub
