Bác HieuCD giúp em mấy đườngBỏ Dic được không bạn
Bác HieuCD giúp em mấy đườngBỏ Dic được không bạn
Bỏ Dic được không bạn
Viết thử xem sao, tương tự code cũ chỉ bỏ Dic là ổnCon 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.
Nhờ Bác Hiếu góp ý thêm ạ!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í
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 ơiNhờ 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
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áp dụng sheet có dấu đi bạn ơi
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
Chuẩn rồi Thêm lệnh Exit Sub sau khi gán kết quả để tăng tốc codeNhờ 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 sao không được nhỉ bạn ợiKhô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
Copy code vào sheet CTdạ xin cảm ơn thật tuyệt. Xin hỏi có cách nào làm trên Module không ạ
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
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
Chuẩn rồi Thêm lệnh Exit Sub sau khi gán kết quả để tăng tốc code
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ử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ói cụ thể hơn mới rỏ lỗi gì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 ạ.
Ý 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 ạ.Nói cụ thể hơn mới rỏ lỗi gì
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
Xài mảng đây:Con chưa viết được mảng, trừ khi sử dụng worksheetfunction thì may ra có thể.
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
Dạ con cảm ơn Thầy nhiều.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
Bạn có thể nói rõ hơn được không ạ?áp dụng sao không được nhỉ bạn ợi
tensheet = "ng" & ChrW(7841) & "ch s" & ChrW(7899)Bạn có thể nói rõ hơn được không ạ?
Bạn chép code này đè lên cái cũ nhé
ThânMã: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
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) Ông này hay nhậu nên ít rảnh;(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.
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!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
Bạn gởi file cụ thể lên đi, tưởng tượng ra ý bạn muốn thì khó quá.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!
DIỄN ĐÀN GIẢI PHÁP EXCEL