Trong lúc chờ công thức thì cô giáo dùng thử macro này và kiểm tra kết quả xem đúng không nha!
Option Explicit
Sub GPE()
Dim Lr&, i%, Arr(), Dic As Object, Key, j%, ws As Worksheet
Dim Res(1 To 1000, 1 To 6), k&, Dic1 As Object, key1
Set Dic = CreateObject("Scripting.Dictionary")
Set Dic1 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For Each ws In ThisWorkbook.Sheets
If ws.Name = "LS" Then
Arr = ThisWorkbook.Sheets("LS").Range("A5:M33").Value
For i = 3 To UBound(Arr)
If Arr(i, 1) = "" Then Arr(i, 1) = Arr(i - 1, 1)
If Arr(i, 2) <> "" Then
For j = 3 To UBound(Arr, 2)
key1 = Split(Arr(i, j), "-")(1)
If Not Dic1.exists(key1) Then Dic1.Add (key1), ""
Key = Split(Arr(i, j), "-")(1) & "|" & Arr(i, 2) & "|" & _
Split(Arr(i, j), "-")(0) & "|" & Arr(i, 1) & "|" & Arr(1, j) & "|" & "LS"
If Not Dic.exists(Key) Then Dic.Add (Key), ""
Next j
End If
Next i
ElseIf ws.Name = "LC" Then
Arr = ThisWorkbook.Sheets("LC").Range("A5:O33").Value
For i = 2 To UBound(Arr)
If Arr(i, 1) = "" Then Arr(i, 1) = Arr(i - 1, 1)
If Arr(i, 2) <> "" Then
For j = 3 To UBound(Arr, 2)
key1 = Split(Arr(i, j), "-")(1)
If Not Dic1.exists(key1) Then Dic1.Add (key1), ""
Key = Split(Arr(i, j), "-")(1) & "|" & Arr(i, 2) & "|" & _
Split(Arr(i, j), "-")(0) & "|" & Arr(i, 1) & "|" & Arr(1, j) & "|" & "LC"
If Not Dic.exists(Key) Then Dic.Add (Key), ""
Next j
End If
Next i
End If
Next ws
For Each key1 In Dic1.keys
For Each Key In Dic.keys
If Split(Key, "|")(0) = key1 Then
k = k + 1
Res(k, 1) = Split(Key, "|")(0)
Res(k, 2) = Split(Key, "|")(1)
Res(k, 3) = Split(Key, "|")(2)
Res(k, 4) = Split(Key, "|")(3)
Res(k, 5) = Split(Key, "|")(4)
Res(k, 6) = Split(Key, "|")(5)
End If
Next Key
Next key1
With ThisWorkbook.Sheets("LOC")
.Range("B5:G10000").ClearContents
.Range("B5").Resize(k, 6).Value = Res
.Range("B5:G10000").WrapText = False
.Sort.SortFields.Clear
Lr = .Range("B" & Rows.Count).End(xlUp).Row
.Sort.SortFields.Add2 Key:=.Range("B5:B" & Lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
.Sort.SortFields.Add2 Key:=.Range("E5:E" & Lr), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With .Sort
.SetRange ThisWorkbook.Sheets("LOC").Range("B4:G" & Lr)
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
End With
MsgBox "Done"
Application.ScreenUpdating = True
End Sub
Làm xong mới xem thì thấy là nhờ chỉ cho hàm để có được kết quả.
Option Explicit
Public Dic As Object, DataS(), DataC(), TieuDeS(), TieuDeC()
Sub NapDic()
Dim i&, j&, t&
Dim Key
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("LS")
DataS = .Range("C6:M35").Value
TieuDeS = .Range("C5:M5").Value
For i = 1 To UBound(DataS)
For j = 1 To UBound(DataS, 2)
If DataS(i, j) <> Empty Then
Key = VBA.Trim(Split(DataS(i, j), "-")(1))
If Not Dic.exists(Key) Then
t = t + 1: Dic.Add (Key), 0
Dic(Key) = i & "," & j
Else
Dic(Key) = Dic(Key) & "|" & i & "," & j
End If
End If
Next j
Next i
End With
With Sheets("LC")
DataC = .Range("c6:M35").Value
TieuDeC = .Range("C5:M5").Value
For i = 1 To UBound(DataC)
For j = 1 To UBound(DataC, 2)
If DataC(i, j) <> Empty Then
Key = VBA.Trim(Split(DataC(i, j), "-")(1))
If Not Dic.exists(Key) Then
t = t + 1: Dic.Add (Key), 0
If Dic(Key) = Empty Then
Dic(Key) = "#" & i & "," & j
Else
Dic(Key) = Dic(Key) & "#" & i & "," & j
End If
Else
If InStr(Dic(Key), "#") = False Then
Dic(Key) = Dic(Key) & "#" & i & "," & j
Else
Dic(Key) = Dic(Key) & "|" & i & "," & j
End If
End If
End If
Next j
Next i
End With
Sheets("TKB").Range("X1").Resize(Dic.Count) = Application.Transpose(Dic.Keys)
End SubOption Explicit
Sub TKB()
Dim i&, j&, t&, k&, R&, Col&
Dim S, S1, S2, Arr(), KQ(1 To 30, 1 To 11), TD()
Dim GV As String, Buoi As String, Key
If Dic Is Nothing Then Call NapDic
With Sheets("TKB")
GV = .Range("H3")
Buoi = .Range("H2")
For Each Key In Dic.Keys
If .Range("H3") = Empty Then
If Buoi Like "BU?I SÁNG" And InStr(Dic(Key), "#") = 0 Then S = Split(Dic(Key), "#")(0): Arr = DataS: TD = TieuDeS
If Buoi Like "BU?I CHI?U" And Left(Dic(Key), 1) = "#" Then If InStr(Dic(Key), "#") Then S = Split(Dic(Key), "#")(1): Arr = DataC: TD = TieuDeC
Else
If Key = GV Then
If Buoi Like "BU?I SÁNG" Then S = Split(Dic(Key), "#")(0): Arr = DataS: TD = TieuDeS
If Buoi Like "BU?I CHI?U" Then If InStr(Dic(Key), "#") Then S = Split(Dic(Key), "#")(1): Arr = DataC: TD = TieuDeC
End If
End If
S1 = Split(S, "|")
For j = 0 To UBound(S1)
S2 = Split(S1(j), ",")
R = S2(0)
Col = S2(1)
KQ(R, Col) = Arr(R, Col)
Next j
Next Key
End With
With Sheets("TKB")
.Range("C5").Resize(30, 11).ClearContents
.Range("C5:M5") = TD
.Range("C6").Resize(30, 11) = KQ
End With
MsgBox "Đa thành công"
End Sub
