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

Liên hệ QC
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í
 
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:
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
 
á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
 
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
 
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
 
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ả
 
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 ạ.
 
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,
 
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
 
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:
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 ạ?
 
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
 
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
 
(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.
. . . . .
 
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!
 
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á.
 
Web KT
Back
Top Bottom