uhm, đây file mới này thử còn sai không
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 Subchạy code nầy xem sao? không được là bỏ của chạy lấy người
Sub Vlookup()
Dim Darr(), Sarr(), Arr(), Dic As Object, i As Long, RKQ As Long, R As Long, C As Integer, Tmp As String
'Sheets("Phieu").Shapes("Rounded Rectangle 1").Visible = True
Application.DisplayAlerts = False
Application.ScreenUpdating = False
RKQ = Range("A3").CurrentRegion.Rows.Count - 1
If RKQ < 4 Then
MsgBox ("Khong co du lieu Ma de lay ten, thoat chuong trinh"): Exit Sub
End If
Set Dic = CreateObject("scripting.dictionary")
Sarr = Range("A4").Resize(RKQ).Value
ReDim Arr(1 To RKQ, 1 To 1)
For i = 1 To RKQ
Tmp = Sarr(i, 1)
If Not Dic.exists(Tmp) Then
Dic.Add Tmp, 1
Dic.Add Tmp & "#" & 1, i
Else
k = Dic.Item(Tmp) + 1
Dic.Item(Tmp) = k
Dic.Add Tmp & "#" & k, i
End If
Next i
Workbooks.Open Filename:=ThisWorkbook.Path & "\DULIEU.XLSX", ReadOnly:=True
With ActiveWorkbook.Sheets("NNT")
C = .Range("XX4").End(xlToLeft).Column
R = .Range("A3").CurrentRegion.Rows.Count - 1
Darr = .Range("A4").Resize(R, C).Value
End With
ActiveWorkbook.Close False
For j = 1 To C Step 3
For i = 1 To R
Tmp = Darr(i, j)
If Tmp = "" Then Exit For
If Dic.exists(Tmp) Then
For k = 1 To Dic.Item(Tmp)
n = n + 1
Arr(Dic.Item(Darr(i, j) & "#" & k), 1) = Darr(i, j + 1)
Next k
If n = RKQ Then GoTo Thoat
End If
Next i
Next j
Thoat:
Range("B4").Resize(RKQ) = Arr
'Sheets("Phieu").Shapes("Rounded Rectangle 1").Visible = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub
