Sub TachKiemKe()
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 key As String, key2 As String
Dim i As Long, ik As Long, k As Long, rk As Long, n As Byte, j As Byte, jk As Byte
Application.ScreenUpdating = False
With Sheets("TK")
sArr = .Range("A2:N" & .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 = 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
Set Sh = Sheets(cArr(n, 1)) 'set sheet n
i = Sh.Cells(Rows.Count, j - 1).End(xlUp).Row
If i > 17 Then Sh.Range(Sh.Cells(18, j - 1), Sh.Cells(i, j - 1)).ClearContents 'xoa ket qua truoc
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
k = 0
For i = 1 To UBound(S) ' gán ket qua cua các cot
ik = CLng(S(i))
If InStr("HB,K", key) Then 'Sheet Hb va K
key2 = key & "#" & sArr(ik, 1) & "#" & sArr(ik, 3)
If Not .exists(key2) Then
k = k + 1
.Add key2, k
For j = 1 To UBound(Res, 2) ' gán ket qua cua cot j
If Res(1, j) > 0 Then Res(2, j)(k, 1) = sArr(ik, Res(1, j))
Next j
Else
rk = .Item(key2)
Res(2, 7)(rk, 1) = Res(2, 7)(rk, 1) + sArr(ik, Res(1, 7))
End If
Else 'Sheet khac
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
End If
Next i
Sheets(cArr(n, 1)).Range("C18") = 1
Sheets(cArr(n, 1)).Range("C18").Resize(UBound(S)).DataSeries
For j = 1 To UBound(Res, 2) ' gán ket qua vào sheet n
If Res(1, j) > 0 Then
Sh.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
