chạy code nầy xem sao? không được là bỏ của chạy lấy ngườiMã: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
Code này đổi thuật toán --> cho phép tốc độ cải thiện đáng kể.