Xin viết dùng mã vba thay thế cho hàm vlookup

HieuCD

Chuyên gia GPE
Tham gia ngày
14 Tháng chín 2010
Bài viết
7,237
Được thích
14,261
Điểm
1,860
Con chào Bác Hiếu,
Con chưa viết được mảng, trừ khi sử dụng worksheetfunction thì may ra có thể.
Bác cho con thêm một cách tham khảo với ạ.
Cảm ơn Bác.
Viết thử xem sao, tương tự code cũ chỉ bỏ Dic là ổn
Dic dùng khi tìm nhiều kết quả, 1 kết quả thì hơi lãng phí
 

NHN_Phương

Thành viên tích cực
Tham gia ngày
5 Tháng mười một 2015
Bài viết
1,241
Được thích
516
Điểm
360
Nơi ở
Hà Nội
Viết thử xem sao, tương tự code cũ chỉ bỏ Dic là ổn
Dic dùng khi tìm nhiều kết quả, 1 kết quả thì hơi lãng phí
Nhờ Bác Hiếu góp ý thêm ạ!
Mã:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long, Vung As Variant, Ws As Worksheet
    Set Ws = Sheets("MA")
    Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3)
    If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
        If Target.Count = 1 Then
            For I = 1 To UBound(Vung)
                If Target.Value = Vung(I, 1) Then
                  Target.Offset(, 1) = Vung(I, 2)
                  Target.Offset(, 2) = Vung(I, 3)
                End If
            Next I
        End If
     End If
End Sub
 
Lần chỉnh sửa cuối:

cõi ta bà

Thành viên mới
Tham gia ngày
23 Tháng mười hai 2018
Bài viết
48
Được thích
4
Điểm
15
Tuổi
40
Nhờ Bác Hiếu góp ý thêm ạ!
Mã:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long, Vung As Variant, Ws As Worksheet
    Set Ws = Sheets("MA")
    Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3)
    If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
        If Target.Count = 1 Then
            For I = 1 To UBound(Vung)
                If Target.Value = Vung(I, 1) Then
                  Target.Offset(, 1) = Vung(I, 2)
                  Target.Offset(, 2) = Vung(I, 3)
                End If
            Next I
        End If
     End If
End Sub
áp dụng sheet có dấu đi bạn ơi
 

NHN_Phương

Thành viên tích cực
Tham gia ngày
5 Tháng mười một 2015
Bài viết
1,241
Được thích
516
Điểm
360
Nơi ở
Hà Nội
áp dụng sheet có dấu đi bạn ơi
Không sử dụng code của OT được đâu bạn vì nó rất dở, chỉ là OT cố viết theo gợi ý của Bác Hiếu để đưowjc Bác ấy chỉ dẫn thêm thôi :D
Trong trường hợp nếu nhập từ khóa không có trong danh mục từ khóa tìm kiếm thì OT chưa khắc phục được lỗi này.
Nếu bạn muốn thử trên sheet "Ngạch sớ" có dấu thì đây ạ:
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long, Vung As Variant, Ws As Worksheet, Key As String
    Dim tensheet As String
    tensheet = "ng" & ChrW(7841) & "ch s" & ChrW(7899)
    Set Ws = Sheets(tensheet)
    Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3)
    If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
        If Target.Count = 1 Then
            Key = Target.Value
            For I = 1 To UBound(Vung)
                If Key = Vung(I, 1) Then
                    Target.Offset(, 1) = Vung(I, 2)
                    Target.Offset(, 2) = Vung(I, 3)
                    Exit Sub
                End If
            Next I
        End If
     End If
End Sub
Sửa: bổ thêm Exit Sub để tăng tốc :D
 

HieuCD

Chuyên gia GPE
Tham gia ngày
14 Tháng chín 2010
Bài viết
7,237
Được thích
14,261
Điểm
1,860
Nhờ Bác Hiếu góp ý thêm ạ!
Mã:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long, Vung As Variant, Ws As Worksheet
    Set Ws = Sheets("MA")
    Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3)
    If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
        If Target.Count = 1 Then
            For I = 1 To UBound(Vung)
                If Target.Value = Vung(I, 1) Then
                  Target.Offset(, 1) = Vung(I, 2)
                  Target.Offset(, 2) = Vung(I, 3)
                End If
            Next I
        End If
     End If
End Sub
Chuẩn rồi :) Thêm lệnh Exit Sub sau khi gán kết quả để tăng tốc code
 

cõi ta bà

Thành viên mới
Tham gia ngày
23 Tháng mười hai 2018
Bài viết
48
Được thích
4
Điểm
15
Tuổi
40
Không sử dụng code của OT được đâu bạn vì nó rất dở, chỉ là OT cố viết theo gợi ý của Bác Hiếu để đưowjc Bác ấy chỉ dẫn thêm thôi :D
Trong trường hợp nếu nhập từ khóa không có trong danh mục từ khóa tìm kiếm thì OT chưa khắc phục được lỗi này.
Nếu bạn muốn thử trên sheet "Ngạch sớ" có dấu thì đây ạ:
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long, Vung As Variant, Ws As Worksheet, Key As String
    Dim tensheet As String
    tensheet = "ng" & ChrW(7841) & "ch s" & ChrW(7899)
    Set Ws = Sheets(tensheet)
    Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3)
    If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
        If Target.Count = 1 Then
            Key = Target.Value
            For I = 1 To UBound(Vung)
                If Key = Vung(I, 1) Then
                    Target.Offset(, 1) = Vung(I, 2)
                    Target.Offset(, 2) = Vung(I, 3)
                    Exit Sub
                End If
            Next I
        End If
     End If
End Sub
Sửa: bổ thêm Exit Sub để tăng tốc :D
áp dụng sao không được nhỉ bạn ợi
 

HieuCD

Chuyên gia GPE
Tham gia ngày
14 Tháng chín 2010
Bài viết
7,237
Được thích
14,261
Điểm
1,860
dạ xin cảm ơn thật tuyệt. Xin hỏi có cách nào làm trên Module không ạ
Copy code vào sheet CT
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
        If Target.Count = 1 Then
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            
            Target.Offset(0, 1).Resize(, 2) = Empty
            Call VlookupVBA(Target)
            
            Application.ScreenUpdating = True
            Application.EnableEvents = True
        End If
     End If
End Sub
Tạo 1 Module và dán code
Mã:
Sub VlookupVBA(ByVal Target As Range)
    Dim i As Long, sRow As Long
    Dim sArr(), iKey As String, TenSheet As String
    
    TenSheet = "Ng" & ChrW(7841) & "ch s" & ChrW(7899)
    With Sheets(TenSheet)
      i = .Range("B" & Rows.Count).End(xlUp).Row
      If i < 3 Then Exit Sub
      sArr = .Range("B3:D" & i).Value
    End With
    
    iKey = UCase(Target.Value)
    sRow = UBound(sArr)
    For i = 1 To sRow
      If UCase(sArr(i, 1)) = iKey Then
        Target.Offset(, 1) = sArr(i, 2)
        Target.Offset(, 2) = sArr(i, 3)
        Exit Sub
      End If
    Next i
End Sub
Code chỉ xử lý 1 kết quả
 

NHN_Phương

Thành viên tích cực
Tham gia ngày
5 Tháng mười một 2015
Bài viết
1,241
Được thích
516
Điểm
360
Nơi ở
Hà Nội
Chuẩn rồi :) Thêm lệnh Exit Sub sau khi gán kết quả để tăng tốc code
Dạ, cảm ơn Bác Hiếu!
Nếu không sử dụng Dic thì con chưa biết khắc phục trường hợp này:
Trong trường hợp nếu nhập từ khóa không có trong danh mục từ khóa tìm kiếm thì OT chưa khắc phục được lỗi này.
Con đang tính thêm 1 vòng lặp nữa để làm việc này nhưng con chưa thử :D
Bác chỉ thêm cho con ạ.
 

HieuCD

Chuyên gia GPE
Tham gia ngày
14 Tháng chín 2010
Bài viết
7,237
Được thích
14,261
Điểm
1,860

huonglien1901

GPE là ngôi nhà thứ 2 của tôi!!!
Tham gia ngày
17 Tháng tư 2016
Bài viết
2,465
Được thích
2,098
Điểm
360
Tuổi
28
Nói cụ thể hơn mới rỏ lỗi gì
Ý bạn OT đang nói đến việc tìm kiếm trong vùng đó mà không có sẽ xảy ra lỗi #NA đó Anh, Bạn đó chắc muốn khử lỗi #NA này, Em đoán vậy, không biết đúng không nữa,
 

NHN_Phương

Thành viên tích cực
Tham gia ngày
5 Tháng mười một 2015
Bài viết
1,241
Được thích
516
Điểm
360
Nơi ở
Hà Nội
Nói cụ thể hơn mới rỏ lỗi gì
Dạ,ví dụ trong trường hợp nhập từ khóa là "AB" vào sheet "CT" mà trong sheet "Ngạch sớ" tại cột B không có từ khóa này Bác ạ.
Thông thường nếu nhập từ khóa "AB" nếu mà dữ liệu 2 cột liền kề không có dữ liệu thì không sao nhưng nếu có dữ liệu rồi thì nó sẽ để nguyên dữ liệu cũ.

Con khắc phục như thế này, thêm dòng:
Target.Offset(, 1).Resize(, 2).ClearContents
hình như có vẻ ổn :D
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim I As Long, Vung As Variant, Ws As Worksheet, Key As String
    Dim tensheet As String
    tensheet = "ng" & ChrW(7841) & "ch s" & ChrW(7899)
    Set Ws = Sheets(tensheet)
    Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 3)
    If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
        If Target.Count = 1 Then
            Target.Offset(, 1).Resize(, 2).ClearContents
            Key = Target.Value
            For I = 1 To UBound(Vung)
                If Key = Vung(I, 1) Then
                    Target.Offset(, 1) = Vung(I, 2)
                    Target.Offset(, 2) = Vung(I, 3)
                    Exit Sub
                End If
            Next I
        End If
     End If
End Sub
 

Ba Tê

Gội Rồi Mới Cạo
Tham gia ngày
5 Tháng năm 2009
Bài viết
11,711
Được thích
16,718
Điểm
1,860
Tuổi
61
Nơi ở
An Giang
Con chưa viết được mảng, trừ khi sử dụng worksheetfunction thì may ra có thể.
Xài mảng đây:
Muốn bẫy lỗi gì thêm thì thêm vào.
PHP:
Option Explicit
Option Compare Text

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Vung(), I As Long, R As Long, DK As Boolean
If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
    If Target.Count = 1 Then
        Vung = Sheets("MA").Range("B3", Sheets("MA").Range("B10000").End(xlUp)).Resize(, 3).Value
        R = UBound(Vung)
        With Target
            .Offset(, 1).Resize(, 2).ClearContents
            For I = 1 To R
                If .Value = Vung(I, 1) Then
                    .Offset(, 1) = Vung(I, 2)
                    .Offset(, 2) = Vung(I, 3)
                    DK = True
                    Exit Sub
                End If
            Next I
        End With
        If DK = False Then MsgBox "Khong tim thay Coi Ta Ba", , "GPE"
    End If
End If
End Sub
 
Lần chỉnh sửa cuối:

NHN_Phương

Thành viên tích cực
Tham gia ngày
5 Tháng mười một 2015
Bài viết
1,241
Được thích
516
Điểm
360
Nơi ở
Hà Nội
Xài mảng đây:
Muốn bẫy lỗi gì thêm thì thêm vào.
PHP:
Option Explicit
Option Compare Text
Private Sub Worksheet_Change(ByVal Target As Range)
Dim Vung(), I As Long, R As Long, DK As Boolean
If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
    If Target.Count = 1 Then
        Vung = Sheets("MA").Range("B3", Sheets("MA").Range("B10000").End(xlUp)).Resize(, 3).Value
        R = UBound(Vung)
        For I = 1 To R
            If Target.Value = Vung(I, 1) Then
                  Target.Offset(, 1) = Vung(I, 2)
                  Target.Offset(, 2) = Vung(I, 3)
                DK = True
                Exit Sub
            End If
        Next I
        If DK = False Then MsgBox "Khong tim thay Coi Ta Ba", , "GPE"
    End If
End If
End Sub
Dạ con cảm ơn Thầy nhiều.
Cái MsgBox của Thầy vui vẻ quá ạ :D
Bài đã được tự động gộp:

áp dụng sao không được nhỉ bạn ợi
Bạn có thể nói rõ hơn được không ạ?
 

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia ngày
8 Tháng sáu 2006
Bài viết
11,851
Được thích
17,783
Điểm
1,860
Bạn có thể nói rõ hơn được không ạ?
tensheet = "ng" & ChrW(7841) & "ch s" & ChrW(7899)
Sao lại chọn con đường chông gai chi cho khổ vậy?
Cứ tên cúng cơm của nó mà gọi ra mà chưỡi thọi
 

vudinhgiao

Thành viên mới
Tham gia ngày
31 Tháng bảy 2016
Bài viết
47
Được thích
10
Điểm
165
Bạn chép code này đè lên cái cũ nhé
Mã:
Private Sub Worksheet_Change(ByVal Target As Range)
    Dim d, I, Vung, Ws
    Set d = CreateObject("scripting.dictionary")
    Set Ws = Sheets("MA")
    Vung = Ws.Range(Ws.[B3], Ws.[B10000].End(xlUp)).Resize(, 4)
        If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
            If Target.Count = 1 Then
                For I = 1 To UBound(Vung)
                    d.Add Vung(I, 1), Array(Vung(I, 2), Vung(I, 3), Vung(I, 4))
                Next I
                    If d.exists(UCase(Target.Value)) Then
                        Target.Offset(, 1) = d.Item(UCase(Target.Value))(0)
                        Target.Offset(, 2) = d.Item(UCase(Target.Value))(1)
                        Target.Offset(, 5) = d.Item(UCase(Target.Value))(2)
                    End If
            End If
         End If
End Sub
Thân
Tiện quá bác ạ. Nếu rảnh bác có thể thêm chú thích các dòng được không ạ, em gà quá nên không hiểu, nhưng lại muốm áp dụng qua các bảng có cấu tạo khác. Cảm ơn bác
 

SA_DQ

/(hông là gì!
Thành viên danh dự
Tham gia ngày
8 Tháng sáu 2006
Bài viết
11,851
Được thích
17,783
Điểm
1,860
(1) Nếu rảnh bác có thể thêm chú thích các dòng được không ạ, (2) em gà quá nên không hiểu, nhưng lại muốm áp dụng qua các bảng có cấu tạo khác.
(1) Ông này hay nhậu nên ít rảnh;
(2) Bạn không hiểu toàn bộ hay vài dòng trong toàn bộ? Nếu là toàn bộ thì dịch tất tần tật mọi câu lệnh bạn cũng chả xài được.
. . . . .
 

classicgt

Thành viên mới
Tham gia ngày
4 Tháng bảy 2009
Bài viết
12
Được thích
0
Điểm
663
Tuổi
35
Xài mảng đây:
Muốn bẫy lỗi gì thêm thì thêm vào.
PHP:
Option Explicit
Option Compare Text

Private Sub Worksheet_Change(ByVal Target As Range)
Dim Vung(), I As Long, R As Long, DK As Boolean
If Not Intersect(Target, Range("B4:B1000")) Is Nothing Then
    If Target.Count = 1 Then
        Vung = Sheets("MA").Range("B3", Sheets("MA").Range("B10000").End(xlUp)).Resize(, 3).Value
        R = UBound(Vung)
        With Target
            .Offset(, 1).Resize(, 2).ClearContents
            For I = 1 To R
                If .Value = Vung(I, 1) Then
                    .Offset(, 1) = Vung(I, 2)
                    .Offset(, 2) = Vung(I, 3)
                    DK = True
                    Exit Sub
                End If
            Next I
        End With
        If DK = False Then MsgBox "Khong tim thay Coi Ta Ba", , "GPE"
    End If
End If
End Sub
Vâng thưa anh, khi em muốn điều chỉnh lấy dữ liệu ở sheet "MA" là cột 2, giá trị tìm kiếm thay sang ở cột 5, 6... ở sheet "CT" thì chỉnh như thế nào ạ? và khi quét vùng nhập dữ liệu ở cột B sheet "CT" xóa thì dữ liệu tìm kiếm không xóa theo. Như vậy phải khắc phục như thế nào ạ? Em chân thành cảm ơn!
 

Ba Tê

Gội Rồi Mới Cạo
Tham gia ngày
5 Tháng năm 2009
Bài viết
11,711
Được thích
16,718
Điểm
1,860
Tuổi
61
Nơi ở
An Giang
Vâng thưa anh, khi em muốn điều chỉnh lấy dữ liệu ở sheet "MA" là cột 2, giá trị tìm kiếm thay sang ở cột 5, 6... ở sheet "CT" thì chỉnh như thế nào ạ? và khi quét vùng nhập dữ liệu ở cột B sheet "CT" xóa thì dữ liệu tìm kiếm không xóa theo. Như vậy phải khắc phục như thế nào ạ? Em chân thành cảm ơn!
Bạn gởi file cụ thể lên đi, tưởng tượng ra ý bạn muốn thì khó quá.
 
Top Bottom