Sub Vlookup()
Dim DRng As Range, SRng As Range, Rng As Range, Arr(), Dic As Object, i As Long, LastKQ As Long, LastR As Long, LastC As Integer, Tmp
'Sheets("Phieu").Shapes("Rounded Rectangle 1").Visible = True
Application.DisplayAlerts = False
Application.ScreenUpdating = False
LastKQ = Range("A3").CurrentRegion.Rows.Count + 2
If LastKQ < 4 Then
MsgBox ("Khong co du lieu Ma de lay ten, thoat chuong trinh"): Exit Sub
End If
Set Dic = CreateObject("scripting.dictionary")
Set SRng = Range("A4:A" & LastKQ)
ReDim Arr(1 To SRng.Rows.Count, 1 To 1)
Workbooks.Open Filename:=ThisWorkbook.Path & "\DULIEU.XLSX", ReadOnly:=True
With ActiveWorkbook.Sheets("NNT")
LastR = .Range("A3").CurrentRegion.Rows.Count + 2
If LastR < 4 Then
MsgBox ("Khong co du lieu nguon, thoat chuong trinh"): Exit Sub
End If
LastC = Range("XX4").End(xlToLeft).Column
For j = 1 To LastC Step 3
Set DRng = Range(Cells(1, j), Cells(LastR, j))
If k > 0 Then
n = 0
For i = 1 To k
Set Rng = DRng.Find(SRng(Dic.Item(i), 1), DRng(3, 1), xlValues, xlWhole)
If Not Rng Is Nothing Then
Arr(Dic.Item(i), 1) = DRng(Rng.Row, 2).Value
Else
n = n + 1
Dic.Item(n) = Dic.Item(i)
End If
Next i
If n = 0 Then Exit For
k = n
Else
For i = 1 To UBound(Arr)
Set Rng = DRng.Find(SRng(i, 1), DRng(3, 1), xlValues, xlWhole)
If Not Rng Is Nothing Then
Arr(i, 1) = DRng(Rng.Row, 2).Value
Else
k = k + 1
Dic.Item(k) = i
Arr(i, 1) = "Khong tim thay du lieu"
End If
Next i
If k = 0 Then Exit For
End If
Next j
End With
ActiveWorkbook.Close False
Range("B4").Resize(UBound(Arr)) = Arr
'Sheets("Phieu").Shapes("Rounded Rectangle 1").Visible = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
