Thay hàm Vlookkup bằng Code VBA (4 người xem)

hoahuongduong1986 · 18/4/19

Kính gửi các Anh Chị và các bạn trong diễn đàn;

Em có số liệu và bảng mã như File kèm theo. Khi làm việc lọc bằng Vlookup với dữ liệu toàn Đơn vị khoảng 100k dòng thì bị đơ máy. Anh chị giúp em cách thay hàm VLookup bằng VBA giúp em với ạ. Em xin cảm ơn anh chị.

Hoàng Nhật Phương · 18/4/19

hoahuongduong1986 đã viết:
Kính gửi các Anh Chị và các bạn trong diễn đàn;

Em có số liệu và bảng mã như File kèm theo. Khi làm việc lọc bằng Vlookup với dữ liệu toàn Đơn vị khoảng 100k dòng thì bị đơ máy. Anh chị giúp em cách thay hàm VLookup bằng VBA giúp em với ạ. Em xin cảm ơn anh chị.

Bạn thử code sau:

Mã:

Option Explicit

Public Sub sGpe()
    Rem code by nickname BaTê -- GiaiPhapExcel
    Dim Dic As Object, sArr(), dArr(), tArr(), I As Long, J As Long, r As Long, Rw As Long, Tem As String
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheets("Bang ma").Range("B2", Sheets("Bang ma").Range("B1000000").End(xlUp)).Resize(, 2).Value
    r = UBound(sArr)
        For I = 1 To r
            Dic.Item(UCase(sArr(I, 1))) = I
        Next I
    tArr = Sheets("Sao ke").Range("D2", Sheets("Sao ke").Range("D1000000").End(xlUp)).Value
    r = UBound(tArr)
    ReDim dArr(1 To r, 1 To 2)
        For I = 1 To r
            Tem = UCase(tArr(I, 1))
            If Dic.Exists(Tem) Then
                Rw = Dic.Item(Tem)
                dArr(I, 1) = sArr(Rw, 2)
            Else
                dArr(I, 1) = "CH" & ChrW(431) & "A C" & ChrW(211) & " M" & ChrW(195)
            End If
        Next I
        Sheets("Sao ke").Range("E2").Resize(r) = dArr
    Set Dic = Nothing
End Sub

Ba Tê · 18/4/19

Nguyễn Hoàng Oanh Thơ đã viết:

Bạn thử code sau:

Mã:

Option Explicit

Public Sub sGpe()
    Rem code by nickname BaTê -- GiaiPhapExcel
    Dim Dic As Object, sArr(), dArr(), tArr(), I As Long, J As Long, r As Long, Rw As Long, Tem As String
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheets("Bang ma").Range("B2", Sheets("Bang ma").Range("B1000000").End(xlUp)).Resize(, 2).Value
    r = UBound(sArr)
        For I = 1 To r
            Dic.Item(UCase(sArr(I, 1))) = I
        Next I
    tArr = Sheets("Sao ke").Range("D2", Sheets("Sao ke").Range("D1000000").End(xlUp)).Value
    r = UBound(tArr)
    ReDim dArr(1 To r, 1 To 2)
        For I = 1 To r
            Tem = UCase(tArr(I, 1))
            If Dic.Exists(Tem) Then
                Rw = Dic.Item(Tem)
                dArr(I, 1) = sArr(Rw, 2)
            Else
                dArr(I, 1) = "CH" & ChrW(431) & "A C" & ChrW(211) & " M" & ChrW(195)
            End If
        Next I
        Sheets("Sao ke").Range("E2").Resize(r) = dArr
    Set Dic = Nothing
End Sub

Hổng phải của tui!

HieuCD · 18/4/19

Nguyễn Hoàng Oanh Thơ đã viết:

Bạn thử code sau:

Mã:

Option Explicit

Public Sub sGpe()
    Rem code by nickname BaTê -- GiaiPhapExcel
    Dim Dic As Object, sArr(), dArr(), tArr(), I As Long, J As Long, r As Long, Rw As Long, Tem As String
    Set Dic = CreateObject("Scripting.Dictionary")
    sArr = Sheets("Bang ma").Range("B2", Sheets("Bang ma").Range("B1000000").End(xlUp)).Resize(, 2).Value
    r = UBound(sArr)
        For I = 1 To r
            Dic.Item(UCase(sArr(I, 1))) = I
        Next I
    tArr = Sheets("Sao ke").Range("D2", Sheets("Sao ke").Range("D1000000").End(xlUp)).Value
    r = UBound(tArr)
    ReDim dArr(1 To r, 1 To 2)
        For I = 1 To r
            Tem = UCase(tArr(I, 1))
            If Dic.Exists(Tem) Then
                Rw = Dic.Item(Tem)
                dArr(I, 1) = sArr(Rw, 2)
            Else
                dArr(I, 1) = "CH" & ChrW(431) & "A C" & ChrW(211) & " M" & ChrW(195)
            End If
        Next I
        Sheets("Sao ke").Range("E2").Resize(r) = dArr
    Set Dic = Nothing
End Sub

Nên dùng 1 biến hoặc hằng để gán chuổi:
"CH" & ChrW(431) & "A C" & ChrW(211) & " M" & ChrW(195)

Dic.Item(UCase(sArr(I, 1))) = I
Nên lấy luôn giá trị cần tìm làm Item
Dic.Item(UCase(sArr(I, 1))) = sArr(I, 2)

hoahuongduong1986 · 18/4/19

Em cảm ơn chị nhiều ạ. Code chạy được rồi chị ạ. Rất hay Chị ạ. Chúc chị luôn gặp nhiều may mắn và thành công !

Hoàng Nhật Phương · 18/4/19

Ba Tê đã viết:
Hổng phải của tui!

Híc, không phải của Thầy thì con không biết của ai nữa ạ . Còn con thì chưa làm được việc này T_T

HieuCD đã viết:
Nên dùng 1 biến hoặc hằng để gán chuổi:
"CH" & ChrW(431) & "A C" & ChrW(211) & " M" & ChrW(195)

Dic.Item(UCase(sArr(I, 1))) = I
Nên lấy luôn giá trị cần tìm làm Item
Dic.Item(UCase(sArr(I, 1))) = sArr(I, 2)

Con cảm ơn Bác HieuCD đã góp ý ạ.

Chúc Thầy và Bác nhiều sức khỏe.
Oanh Thơ

VetMini · 18/4/19

Nói riết nó như cái đĩa hát cũ (*).
Thời buổi công nghệ thông tin siêu xa lộ mà còn phải lấy cớ 100 ngàn dòng để dùng VBA.
Nâng cấp lên 2016+ rổi học cách sử dụng data model.

(*) đĩa hát cũ: cái dĩa nhựa xài lâu quá có thể nó bị khuyết lờn vòng, đến đúng vòng ấy thì nó không đi vào trong được nữa, cứ quanh mãi vòng ấy và lải nhải 1 câu cả ngày. Do đó có câu ví von như vậy.

Ba Tê · 18/4/19

Nguyễn Hoàng Oanh Thơ đã viết:
Híc, không phải của Thầy thì con không biết của ai nữa ạ . Còn con thì chưa làm được việc này T_T

Nếu là của tôi thì... chắc hồi "năm nẵm" nào đó khi mới vọc Dic.
Hic! Có bị "ghẹo" chút nào không ta?

Hoàng Nhật Phương · 18/4/19

Ba Tê đã viết:
Nếu là của tôi thì... chắc hồi "năm nẵm" nào đó khi mới vọc Dic.
Hic! Có bị "ghẹo" chút nào không ta?

Híc, Thầy bảo "ghẹo" nên con cố tìm ạ.
https://www.giaiphapexcel.com/diend...ế-hàm-vlookup-trong-excel.141461/#post-910491
Chắc lúc đó Thầy viết cho vui, hoặc là code tối ưu cho bài đó còn bài này thì viết khác.
------
Nếu Thầy có cách nào khác gọn hơn hay tối ưu hơn gì đó Thầy cho con tham khảo với ạ.
Cảm ơn Thầy nhiều.

Ba Tê · 19/4/19

Nguyễn Hoàng Oanh Thơ đã viết:
Híc, Thầy bảo "ghẹo" nên con cố tìm ạ.
https://www.giaiphapexcel.com/diendan/threads/code-vba-thay-thế-hàm-vlookup-trong-excel.141461/#post-910491
Chắc lúc đó Thầy viết cho vui, hoặc là code tối ưu cho bài đó còn bài này thì viết khác.
------
Nếu Thầy có cách nào khác gọn hơn hay tối ưu hơn gì đó Thầy cho con tham khảo với ạ.
Cảm ơn Thầy nhiều.

Gọn hay tối ưu thì bạn làm theo gợi ý của HieuCD bài #4 xem sao.
Tôi ít khi viết 1 chuỗi tiếng Việt có dấu trong VBA nên nhìn nó như "người xa lạ".

Lê Hồng Minh83 · 19/4/19

Nguyễn Hoàng Oanh Thơ đã viết:
Híc, Thầy bảo "ghẹo" nên con cố tìm ạ.
https://www.giaiphapexcel.com/diendan/threads/code-vba-thay-thế-hàm-vlookup-trong-excel.141461/#post-910491
Chắc lúc đó Thầy viết cho vui, hoặc là code tối ưu cho bài đó còn bài này thì viết khác.
------
Nếu Thầy có cách nào khác gọn hơn hay tối ưu hơn gì đó Thầy cho con tham khảo với ạ.
Cảm ơn Thầy nhiều.

Mình mới vọc vạch dic nên viết vầy cho dễ hiểu, chỉ cần 2 mảng thôi

Mã:

Sub timkiem()
    Dim i As Long, j As Long, dic As Object, arr(), rarr(), dk As String
    Set dic = CreateObject("scripting.dictionary")
    arr = Sheets("Bang ma").Range("B2", Sheets("Bang ma").Range("C1000000").End(xlUp)).Value
    For i = 1 To UBound(arr, 1)
        dk = arr(i, 1)
        dic.Add (dk), arr(i, 2)
    Next i
    With Sheets("Sao ke")
        rarr = .Range("D2", .Range("D1000000").End(xlUp)).Resize(, 2).Value
        For j = 1 To UBound(rarr, 1)
        dk = rarr(j, 1)
        If dic.exists(dk) Then
        rarr(j, 2) = dic.Item(dk)
        Else
        rarr(j, 2) = "CH" & ChrW(431) & "A C" & ChrW(211) & " M" & ChrW(195)
        End If
        Next j
        .Range("E2").Resize(j - 1).ClearContents
        .Range("D2:E2").Resize(j - 1) = rarr
    End With
    Set dic = Nothing
End Sub

VetMini · 19/4/19

Nguyễn Hoàng Oanh Thơ đã viết:
... cách nào khác gọn hơn hay tối ưu hơn gì đó ...

1. Gọn thì không thể gọn hơn. Người viết đã cố tình viết rất "gọn"
2. Tối ưu thì phải tuỳ theo chỉ tiêu tối ưu của bạn là gì. Ở diễn đàn này, chỉ tiêu số 1 của tối ưu là tốc độ.

Nếu sì tin viết code được chấm làm chỉ tiêu thì mới cần cải tiến.
- Lôi cái code lập dictionary ra riêng thành 1 function hoặc sub.
(Với sì tin này, code lập dic có thể được giữ vào thư viện, không phải viết lại)

Nếu xịn hơn nữa thì lôi cả cái code dic và tra dic vào một class module.
Lúc đó, code có thể chọn lựa hoặc dùng Dic hoặc Sorted List để làm bảng tra. Code gọi không cần biết đến chọ nluwaj này. Nó chỉ tra thôi.

LamNA · 19/4/19

Em thì thường dùng code này để làm báo cáo khi dùng
Trong Modules

Mã:

Option Explicit
Public Chk As Boolean, Dic As Object, aResult()
Sub Vlookup()
Dim wks As Worksheet, SrcRng As Range, sArray
  Dim LR As Long, i As Long, n As Long, tmp
  On Error Resume Next
  Set wks = Sheets("Bang Ma")
  Set SrcRng = wks.Range("B2:C60000")
  sArray = SrcRng.Value
  ReDim aResult(1 To UBound(sArray, 1), 1 To UBound(sArray, 2))
  Set Dic = CreateObject("Scripting.Dictionary")
  For i = 1 To UBound(sArray, 1)
    If CStr(sArray(i, 1)) <> "" Then
      tmp = sArray(i, 1)
      If Not Dic.exists(tmp) Then
        LR = LR + 1
        Dic.Add tmp, LR
        aResult(LR, 1) = tmp
        aResult(LR, 2) = sArray(i, 2)
      End If
    End If
  Next
End Sub

Trong Sheet

Mã:

Private Sub Worksheet_Change(ByVal Target As Range)
Dim i As Long, tmp
Dim result()
    Application.EnableEvents = False
    Application.ScreenUpdating = False
    Set Change = Intersect(Range("D2:D600000"), Target)
    If Not Change Is Nothing Then
        If Dic Is Nothing Then Vlookup
        result = Change.Resize(Change.Rows.Count + 1).Value
        ReDim Preserve result(1 To UBound(result), 1 To 2)
 
        For i = 1 To UBound(result) - 1
            If Len(result(i, 1)) Then
                tmp = result(i, 1)
                If Dic.exists(tmp) Then
                    result(i, 1) = aResult(Dic.Item(tmp), 2)
                Else
                    result(i, 1) = "CH" & ChrW(431) & "A C" & ChrW(211) & " M" & ChrW(195)
                End If
            End If
        Next i
        Change.Offset(0, 1).Resize(, 1).Value = result
    End If
 If Not Change Is Nothing Then
  End If
    Application.EnableEvents = True
    Application.ScreenUpdating = True
End Sub

hoahuongduong1986 · 19/4/19

Em cảm ơn anh nhiều !

Hoàng Nhật Phương · 19/4/19

VetMini đã viết:
1. Gọn thì không thể gọn hơn. Người viết đã cố tình viết rất "gọn"
2. Tối ưu thì phải tuỳ theo chỉ tiêu tối ưu của bạn là gì. Ở diễn đàn này, chỉ tiêu số 1 của tối ưu là tốc độ.

Nếu sì tin viết code được chấm làm chỉ tiêu thì mới cần cải tiến.
- Lôi cái code lập dictionary ra riêng thành 1 function hoặc sub.
(Với sì tin này, code lập dic có thể được giữ vào thư viện, không phải viết lại)

Nếu xịn hơn nữa thì lôi cả cái code dic và tra dic vào một class module.
Lúc đó, code có thể chọn lựa hoặc dùng Dic hoặc Sorted List để làm bảng tra. Code gọi không cần biết đến chọ nluwaj này. Nó chỉ tra thôi.

Xin chào Bác VetMini,
Dạ con không có ý đòi hỏi thêm hay đòi hỏi phải tối ưu hơn ạ.
Còn đối với con cảm thấy tối ưu lắm nên mới gửi(chia sẻ) ạ.

Nhưng bì là con hiểu có thể đối với Thầy Ba Tê ,code con đưa lên có lẽ Thầy cảm thấy chưa ưng ý lên Thầy có viết: "Nếu là của tôi thì... chắc hồi "năm nẵm" nào đó khi mới vọc Dic."
Vì vậy con muốn hỏi thêm xem Thầy còn cách nào khác nào khác không ạ?
Con cảm ơn Bác đã thông tin.

VetMini · 19/4/19

Nguyễn Hoàng Oanh Thơ đã viết:
..."năm nẵm" nào đó khi mới vọc Dic."
...

"năm nẵm" ấy cũng tương đối thôi.
Sì tin code ấy không xưa lắm. Tôi nhớ sì tin dùng Object đại trà bà con chỉ dùng mấy năm nay. Trước đó bà con dùng thẳng Object Dic, tức là Dim Dic As Scripting.Dictionary
(tìm bài tôi nói về kết nối trễ và sớm, có nói qua cái này)

@tác giả bài #13: code còn luộm thuộm lắm
1. Dùng tên trùng với hàm có sẵn thì phải đặt nó là private
2. Function/Sub muốn dùng đại trà (làm thư viện) thì phải có ghi chú (comments) rõ rệt. Tói thiểu là phải giải thích nó làm cái gì.
Toi chưa nói đến cách đặt tên biến.

VetMini · 19/4/19

Code dic đại khái nó như vầy:

Sub BuildLookupTable(ByRef Dic As Object, ByRef sArray(), Optional ByVal keyCol = 1, Optional ByVal datCol = 0)
' reads data from 2D array sArray (base 1), and builds a lookup table using a dictionary Dic
' keyCol = column in sArray denoting the key
' datCol = column in sArray to be picked up as data (dic item). If 0, the dic will store corresponding array line number as item
If Dic Is Nothing Then Set Dic = CreateObject("Scripting.Dictionary")
' kể từ đây, code chỉ có ý hướng dẫn, tuỳ ý người thực hiện
' lưu ý là với code dưới đây, nếu key xuất hiện nhiều lần thì lần cuối sẽ được ghi
' nếu thực sự muốn lần đầu như VLookup thì cho vòng lặp đọc ngược mảng
Dim blah blah
For i = 1 to UBound(sArray)
If datCol Then
Dic(sArray(i, keyCol)) = sArray(i, datCol)
Else
Dic(sArray(i,keyCol)) = i
End If
Next i
End Sub

Code sử dụng:

...
BuildLookupTable Dic, sArray, 1, 2 -> key là cột 1, data là cột 2
' hoặc BuildLookupTable Dic, sArray -> key là cột 1, data là dòng của sArray

be_09 · 19/4/19

hoahuongduong1986 đã viết:
Kính gửi các Anh Chị và các bạn trong diễn đàn;

Em có số liệu và bảng mã như File kèm theo. Khi làm việc lọc bằng Vlookup với dữ liệu toàn Đơn vị khoảng 100k dòng thì bị đơ máy. Anh chị giúp em cách thay hàm VLookup bằng VBA giúp em với ạ. Em xin cảm ơn anh chị.

Xem thử File, sẽ tô màu Cell không tìm thấy.

Thay hàm Vlookkup bằng Code VBA (4 người xem)

Người dùng đang xem chủ đề này

Thành viên thường trực

File đính kèm

Thành viên gắn bó

Cạo Rồi Khỏi Gội

Chuyên gia GPE

Thành viên thường trực

Thành viên gắn bó

Ăn cùng góc phố

Cạo Rồi Khỏi Gội

Thành viên gắn bó

Cạo Rồi Khỏi Gội

Thành viên tiêu biểu

Ăn cùng góc phố

Thành viên tích cực

File đính kèm

Thành viên thường trực

Thành viên gắn bó

Ăn cùng góc phố

Ăn cùng góc phố

Biên Hòa, Đồng Nai

File đính kèm

Đếm ngược thời gian