Sub SoSanh()
Dim aChuan(), aThuc(), S, Arr, Arr2, Res()
Dim eR&, eR2&, sR&, i&, j&, n&, q&, a&
Dim tc&, tc2&, tt&, tt2&
Dim iKey$, tmp$, strThuc$
Const d = 10 'Do lech cho phep
With Sheets("so sanh")
eR = .Range("C" & Rows.Count).End(xlUp).Row
eR2 = .Range("E" & Rows.Count).End(xlUp).Row
If eR < 4 Or eR2 < 4 Then MsgBox ("Khong co du lieu"): Exit Sub
aThuc = .Range("C4:C" & eR).Value
aChuan = .Range("E4:E" & eR2).Value
End With
With CreateObject("scripting.dictionary")
sR = UBound(aChuan)
For i = 1 To sR
tmp = aChuan(i, 1)
j = InStr(1, tmp, "*")
If j > 0 Then
S = Split(tmp, "*")
iKey = S(0)
If .exists(iKey) = False Then
.Add iKey, Array(Array(S(1), S(2)))
Else
Arr = .Item(iKey)
ReDim Preserve Arr(0 To UBound(Arr))
Arr(UBound(Arr)) = Array(S(1), S(2))
.Item(iKey) = Arr
End If
For a = 1 To 2
iKey = S(0) & "*" & S(a)
If .exists(iKey) = False Then
.Add iKey, Array(S(3 - a))
Else
Arr = .Item(iKey)
ReDim Preserve Arr(0 To UBound(Arr))
Arr(UBound(Arr)) = S(3 - a)
.Item(iKey) = Arr
End If
Next a
End If
Next i
sR = UBound(aThuc)
ReDim Res(1 To sR, 1 To 1)
For i = 1 To sR
tmp = aThuc(i, 1)
j = InStr(1, tmp, "*")
If j > 0 Then
S = Split(tmp, "*")
iKey = S(0)
If .exists(iKey) Then
Arr = .Item(iKey)
For j = 0 To UBound(Arr)
For n = 0 To 1
tc = CLng(Arr(j)(n))
For q = 1 To 2
tt = CLng(S(q))
If tt - d <= tc And tt + d >= tc Then
tt2 = CLng(S(3 - q))
iKey = iKey & "*" & tc
Arr2 = .Item(iKey)
For a = 0 To UBound(Arr2)
tc2 = CLng(Arr2(a))
If tt2 - d <= tc2 And tt2 + d >= tc2 Then
Res(i, 1) = "OK"
GoTo DongKe
End If
Next a
End If
Next q
Next n
Next j
End If
End If
DongKe:
Next i
End With
Sheets("so sanh").Range("G4").Resize(sR) = Res
End Sub
