Sub GPE()
Dim Sh As Worksheet
Dim sArr As Variant, shArr As Variant, cArr As Variant
Dim Res As Variant, S As Variant, Arr As Variant
Dim NH As String, Kho As Integer, LH As String
Dim i As Long, ik As Long, n As Byte, j As Byte, jk As Byte
Application.ScreenUpdating = False
With Sheets("TK")
sArr = .Range("A2:M" & .Range("A" & Rows.Count).End(xlUp).Row).Value
End With
With Sheets("DK")
shArr = .Range("A2:N" & .Range("A" & Rows.Count).End(xlUp).Row).Value
cArr = .Range("P2:AC" & .Range("P" & Rows.Count).End(xlUp).Row).Value 'mang cac cot cac sheet
End With
For n = 2 To UBound(cArr) 'xóa kêt qua truoc
If shTest(cArr(n, 1)) Then
For j = 2 To UBound(cArr, 2)
If cArr(n, j) <> Empty Then
With Sheets(cArr(n, 1)) 'set sheet n
i = .Cells(Rows.Count, j - 1).End(xlUp).Row
If i > 17 Then .Range(.Cells(18, j - 1), .Cells(i, j - 1)).ClearContents 'xoa ket qua truoc
End With
End If
Next j
End If
Next n
For n = 1 To UBound(shArr) 'tao mang dieu kien cac sheet
If shArr(n, 1) = Empty And n > 1 Then shArr(n, 1) = shArr(n - 1, 1)
If shTest(shArr(n, 1)) Then
For j = 4 To 12
If shArr(n, j) <> Empty Then shArr(n, 3) = shArr(n, 3) & "," & shArr(n, j)
Next j
Else
shArr(n, 1) = "No Exit"
End If
Next n
With CreateObject("Scripting.Dictionary")
For i = 1 To UBound(sArr) 'Lay dòng cua tung sheet
NH = sArr(i, 12): Kho = sArr(i, 6): LH = sArr(i, 10)
For n = 1 To UBound(shArr)
If shArr(n, 1) = "No Exit" Then GoTo Tiep
If shArr(n, 2) <> Empty Then
If InStr(shArr(n, 2), NH) = 0 Or NH = Empty Then GoTo Tiep
End If
If shArr(n, 3) <> Empty Then
If InStr(shArr(n, 3), Kho) = 0 Or Kho = Empty Then GoTo Tiep
End If
If shArr(n, 13) <> Empty Then
If (Not (shArr(n, 14) = Empty) And LH <> Empty) Or _
(shArr(n, 14) = Empty And LH = Empty) Then GoTo Tiep
End If
Key = shArr(n, 1)
If Not .exists(Key) Then .Add Key, "a," & i Else .Item(Key) = .Item(Key) & "," & i
Tiep:
Next n
Next i
For n = 2 To UBound(cArr)
Key = cArr(n, 1)
If .exists(Key) Then
S = Split(.Item(Key), ",")
If UBound(S) > 0 Then
ReDim Res(1 To 2, 1 To UBound(cArr, 2) - 1) 'mang thu tu cot va ket qua cua sheet thu n
For j = 2 To UBound(cArr, 2)
jk = ViTriCot(cArr, cArr(n, j)) 'thu tu cot sheet TK
If jk > 0 Then
ReDim Arr(1 To UBound(S), 1 To 1)
Res(1, j - 1) = jk 'thu tu cot
Res(2, j - 1) = Arr 'mang ket qua cua cot j-1
End If
Next j
For i = 1 To UBound(S) ' gán ket qua cua các cot
ik = CLng(S(i))
For j = 1 To UBound(Res, 2) ' gán ket qua cua cot j
If Res(1, j) > 0 Then
Res(2, j)(i, 1) = sArr(ik, Res(1, j))
End If
Next j
Next i
For j = 1 To UBound(Res, 2) ' gán ket qua vào sheet n
If Res(1, j) > 0 Then
Sheets(cArr(n, 1)).Range("A18").Offset(, j - 1).Resize(UBound(S)) = Res(2, j)
End If
Next j
End If
End If
Next n
End With
Application.ScreenUpdating = True
End Sub
