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

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

HieuCD đã viết:
Bỏ Dic được không bạn

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.

HieuCD · 26/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
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í

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

HieuCD đã viết:
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

cõi ta bà · 26/5/19

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

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

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

cõi ta bà đã viết:
á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

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

HieuCD · 26/5/19

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

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à · 26/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
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
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

áp dụng sao không được nhỉ bạn ợi

HieuCD · 26/5/19

cõi ta bà đã viết:
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ả

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

HieuCD đã viết:
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ử

Bác chỉ thêm cho con ạ.

HieuCD · 26/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
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:

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ử
Bác chỉ thêm cho con ạ.

Nói cụ thể hơn mới rỏ lỗi gì

huonglien1901 · 26/5/19

HieuCD đã viết:
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,

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

HieuCD đã viết:
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

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ê · 26/5/19

Nguyễn Hoàng Oanh Thơ đã viết:
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

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

Ba Tê đã viết:

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á ạ

Bài đã được tự động gộp: 26/5/19

cõi ta bà đã viết:
á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 · 26/5/19

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 · 26/5/19

concogia đã viết:

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 · 26/5/19

(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 · 28/5/19

Ba Tê đã viết:

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ê · 29/5/19

classicgt đã viết:
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á.

classicgt · 29/5/19

Ba Tê đã viết:
Bạn gởi file cụ thể lên đi, tưởng tượng ra ý bạn muốn thì khó quá.

Vâng, vẫn là file cũ ah!

Bài đã được tự động gộp: 29/5/19

Ba Tê đã viết:
Bạn gởi file cụ thể lên đi, tưởng tượng ra ý bạn muốn thì khó quá.

Ý em là ở Sheet "MA" thứ tự các cột là "mã, tên, đơn vị, đơn giá" khi giá trị tìm kiếm ở sheet "CT" thì thứ tự các cột có thể thay đổi "mã, xx,xx tên, đơn giá, đơn vị..." chẳng hạn. Không theo thứ tự cột thì phải làm thế nào ah?

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

Thành viên gắn bó

Chuyên gia GPE

Thành viên gắn bó

Thành viên mới

Thành viên gắn bó

Chuyên gia GPE

Thành viên mới

Chuyên gia GPE

Thành viên gắn bó

Chuyên gia GPE

GPE là ngôi nhà thứ 2 của tôi!!!

Thành viên gắn bó

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

Thành viên gắn bó

/(hông là gì!

Thành viên mới

/(hông là gì!

Thành viên mới

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

Thành viên mới

File đính kèm

Đếm ngược thời gian