Sub XYZ()
Dim aCheck(), aData(), tArr, Res(), dic As Object
Dim sRow&, i&, j&, iKey$, tmp
Set dic = CreateObject("scripting.dictionary")
With Sheets("data")
aData = .Range("B2", .Range("D" & Rows.Count).End(xlUp)).Value2
End With
sRow = UBound(aData)
For i = 1 To sRow
iKey = aData(i, 1)
If Not dic.exists(iKey) Then
dic.Add iKey, Array(i)
Else
tArr = dic.Item(iKey)
ReDim Preserve tArr(0 To UBound(tArr) + 1)
tArr(UBound(tArr)) = i
dic.Item(iKey) = tArr
End If
Next i
With Sheets("Check")
aCheck = .Range("C2", .Range("D" & Rows.Count).End(xlUp)).Value2
sRow = UBound(aCheck)
ReDim Res(1 To sRow, 1 To 1)
For i = 1 To sRow
iKey = aCheck(i, 1)
If dic.exists(iKey) Then
tmp = aCheck(i, 2)
tmp = CDbl(CDate(Mid(tmp, 7, 4) & Mid(tmp, 3, 4) & Mid(tmp, 1, 2) & Mid(tmp, 11, 9)))
tArr = dic.Item(iKey)
For j = 0 To UBound(tArr)
If tmp >= aData(tArr(j), 2) Then
If tmp <= aData(tArr(j), 3) Then
Res(i, 1) = "Co nam trong du lieu"
Exit For
End If
End If
Next j
End If
Next i
.Range("E2").Resize(sRow).Value = Res
End With
End Sub