VBA - Tìm kiếm dữ liệu với nhiều điều kiện

Liên hệ QC
Tôi tuân thủ nội quy khi đăng bài
Có
M

mraleno

Thành viên chính thức
Tham gia
1/12/09
Bài viết
68
Được thích
18
Em chào các anh em trong diễn đàn. Hôm nay em có một vấn đề với việc dò tìm dữ liệu.

em có một bảng điều kiện A, B, C (trong đó A có tới 3 cột) và một bảng dữ liệu cũng gồm các cột A, B, C
Điều kiện là: nếu trong bảng dữ liệu dòng nào có dữ liệu giống với 3 cột trong bảng điều kiện thì ở cột "Check" mình điền Y

Cái khó là cột A có tới 3 cột nên em phải ghép lần lượt, còn cột B chỉ cần có chuỗi kí tự trùng với điều kiện là được.

Em làm bằng cách ghép các cột với nhau như hơi dư thừa cột và code chạy rất lâu.

Có anh em nào giúp em bằng code VBA được không? Chân thành cảm ơn
 

File đính kèm

  • MAU DO TIM.xlsb
    9.2 KB · Đọc: 35
& đây là 1 phần của đáp án
PHP: 
Sub DoTimNhieuDieuKien()
 Dim RngDK As Range, Cls As Range, Rng5 As Range, sRng As Range, Rg1 As Range
 Dim Sh As Worksheet:                   Dim sTrC As String
 Const MyColor As Integer = 34
 
 Set Sh = ThisWorkbook.Worksheets("Dieu Kien")
 Set RngDK = Sh.UsedRange
 Sheets("Du Lieu").Select
 For Each Cls In Range([A2], [A2].End(xlDown))
    Set sRng = RngDK.Find(Cls.Value, , xlFormulas, xlWhole)
    If Not sRng Is Nothing Then
        Cls.Interior.ColorIndex = MyColor + sRng.Column
        Set Rng5 = Sh.Cells(sRng.Row, "A").Resize(, RngDK.Columns.Count)
        sTrC = Tach(Cls.Offset(, 1).Value)
        For Each Rg1 In Rng5
            If InStr(Rg1.Value, sTrC) Then
                Cls.Offset(, 1).Interior.ColorIndex = MyColor + Rg1.Column
            End If
            If Rg1.Value = Cls.Offset(, 2).Value Then
                Cls.Offset(, 2).Interior.ColorIndex = MyColor + Rg1.Column
            End If
        Next Rg1
    Else
    End If
 Next Cls
End Sub
Mã: 
Function Tach(Goc As String) As String
  ' Nội dung sẽ được bổ sung 1 khi chủ bài đăng hay ai đó sửa lại tiêu đề bài đăng   '
End Function
 
Và đây là 1 phần của đáp án

Mã: 
Option Explicit

Sub ABC()
Dim i&, j&, Lr&, t&
Dim Arr(), ArrDL(), Res()
Dim Dic As Object, Key, Temp
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("DIEU KIEN")
Lr = Sh.Cells(10000, "A").End(xlUp).Row
Arr = Sh.Range("A2:E" & Lr).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
    For j = 1 To 3
        Key = Arr(i, j) & "|" & Arr(i, 5) & "|" & Arr(i, 4)
        If Not Dic.Exists(Key) Then t = t + 1: Dic.Add (Key), t
    Next j
Next i
Set Ws = Sheets("DU LIEU")
...........................
end sub
 
HUONGHCKT đã viết:
Và đây là 1 phần của đáp án

Mã: 
Option Explicit

Sub ABC()
Dim i&, j&, Lr&, t&
Dim Arr(), ArrDL(), Res()
Dim Dic As Object, Key, Temp
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("DIEU KIEN")
Lr = Sh.Cells(10000, "A").End(xlUp).Row
Arr = Sh.Range("A2:E" & Lr).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
    For j = 1 To 3
        Key = Arr(i, j) & "|" & Arr(i, 5) & "|" & Arr(i, 4)
        If Not Dic.Exists(Key) Then t = t + 1: Dic.Add (Key), t
    Next j
Next i
Set Ws = Sheets("DU LIEU")
...........................
end sub
Nhấp chuột vào đây để mở rộng...
Cách sử dụng dic của bác có vẻ giải quyết được vấn đề code chạy chậm. Mong bác chia sẽ phần còn lại giúp mình. Mình đã báo Mod chỉnh sửa giùm phần tiêu đề rồi nhưng chưa được giải quyết. Nếu không được mình xin tạo một thread khác cho đúng nội quy của diễn đàn. Chân thành cảm ơn
 
mraleno đã viết:
Cách sử dụng dic của bác có vẻ giải quyết được vấn đề code chạy chậm. Mong bác chia sẽ phần còn lại giúp mình. Mình đã báo Mod chỉnh sửa giùm phần tiêu đề rồi nhưng chưa được giải quyết. Nếu không được mình xin tạo một thread khác cho đúng nội quy của diễn đàn. Chân thành cảm ơn
Nhấp chuột vào đây để mở rộng...
Bạn phải nhờ Mod sửa lại tiêu đề, chứ nói như trên có lẽ không phải là câu cầu khiến do vậy....
Bạn cứ chờ hoặc lập thớt khác đó là tùy bạn. Bạn đã xem code ở trên đã đến được phần add dic rồi. phần còn lại là (gợi ý nhé) xem trong dic có những gì, và đối chiếu từng dòng dic với dữ liệu để rút ra kết luận theo kiểu hàm If A= b thì Cells(x,y)="Y".
 
SA_DQ đã viết:
Bạn cho biết rằng bạn nhờ bằng cách nào sau đây:
(1) Gỏi tin nhắn cho MODs hay SMOD đang hiện diện trên diễn đàn lúc bạn vô diễn đàn chưa?
(2) Bạn đến đây & đề đạt nguyện vọng của mình chưa: "Nơi đối thoại giữa Ban Quản Trị của Diễn Đàn và thành viên. Hãy cho chúng tôi biết ý kiến của các bạn."
(3) Bạn vô mục "Báo cáo" chưa?
. . . . .
Nếu chưa áp dụng mục nào thì thực hiện lần lược các mục đó đi & mình mong bạn sẽ đạt nguyện vọng;
& . . . . chưa gì đã thấy khó!
Nhấp chuột vào đây để mở rộng...
Mình đã sử dụng cách số (3). Cách số (1) thì mình không biết cách vì khi mình chọn các tên admin thì không hiện ra khung nhắn tin nào hết. Mình sẽ thử thêm cách số (2) như bạn hướng dẫn xem thế nào. Cảm ơn Bạn
 
#4 là những dòng lệnh để thực thi phương án (gồm 2 công đoạn chính) sau:
→1← Tạo vòng lặp để tìm trong BDK (bảng điều kiện) các trị trên cột 'A' của BDL (bảng dữ liệu);
a./ Tìm bỡi phương thức FIND()
Muốn vậy cần xác định trước tiên vùng để tìm kiếm trên trang BDK
b./ Sau tiếp là tạo vòng lặp duyệt lần lượt theo cột 'A' của BDL;
c./ Trường hợp tìm thấy: Thì đối chiếu giữa 2 cột trong BDK với 2 cột trong BDL
→2← Nếu trùng hay khớp thì ghi nhận bằng cách nào đó (Ở macro #4 là bằng màu nền của BDL dòng đang dùng dò tìm)
 
SA_DQ đã viết:
#4 là những dòng lệnh để thực thi phương án (gồm 2 công đoạn chính) sau:
→1← Tạo vòng lặp để tìm trong BDK (bảng điều kiện) các trị trên cột 'A' của BDL (bảng dữ liệu);
a./ Tìm bỡi phương thức FIND()
Muốn vậy cần xác định trước tiên vùng để tìm kiếm trên trang BDK
b./ Sau tiếp là tạo vòng lặp duyệt lần lượt theo cột 'A' của BDL;
c./ Trường hợp tìm thấy: Thì đối chiếu giữa 2 cột trong BDK với 2 cột trong BDL
→2← Nếu trùng hay khớp thì ghi nhận bằng cách nào đó (Ở macro #4 là bằng màu nền của BDL dòng đang dùng dò tìm)
Nhấp chuột vào đây để mở rộng...
à mình hiểu ý của Bác rồi. bác kiểm tra điều kiện từng cột đk 1 và gán nó bằng 1 màu nhất định. Sau đó kiểm tra trên dòng đó nếu 3 ô đều thỏa điện của chung 1 dòng trong BĐK thì sẽ có màu giống nhau như vậy là khớp. Còn số 34 bác tạo lúc đầu là sở thích cá nhân hả. Cảm ơn Bác. Một cách giải quyết khá hay. Khi làm xong rồi mình tìm một code clear format đi là xóa hết các màu đúng không Bác
 
Tìm kiếm dữ liệu với nhiều điều kiện
Giữ đúng lời hứa,
Đây là đáp án của tôi bạn chủ thớt có thể xem, chạy thử trong khi chờ các đáp án khác
Mã: 
Option Explicit

Sub ABC()
Dim i&, j&, Lr&, t&
Dim Arr(), ArrDL(), Res()
Dim Dic As Object, Key, Temp
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("DIEU KIEN")
Lr = Sh.Cells(10000, "A").End(xlUp).Row
Arr = Sh.Range("A2:E" & Lr).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
    For j = 1 To 3
        Key = Arr(i, j) & "|" & Arr(i, 5) & "|" & Arr(i, 4)
        If Not Dic.Exists(Key) Then t = t + 1: Dic.Add (Key), t
    Next j
Next i
Set Ws = Sheets("DU LIEU")
ArrDL = Ws.Range("A2:E" & Ws.Cells(10000, "A").End(xlUp).Row).Value
ReDim Res(1 To UBound(ArrDL), 1 To 1)
For Each Key In Dic.keys
    Temp = Split(Key, "|")(2)
    For i = 1 To UBound(ArrDL)
        If InStr(1, ArrDL(i, 2), Temp) Then
            If Dic.Exists(ArrDL(i, 1) & "|" & ArrDL(i, 3) & "|" & Temp) Then
                Res(i, 1) = "Y"
            End If
        End If
    Next i
Next Key
Ws.Range("E2").Resize(UBound(ArrDL), 1) = Res
Set Dic = Nothing
MsgBox "Xong"
End Sub

Xem file đính kèm (kết quả đang để ở E2 để đối chiếu với kết quả gốc.
 

File đính kèm

  • MAU DO TIM.xlsb
    17.9 KB · Đọc: 40
HUONGHCKT đã viết:
Tìm kiếm dữ liệu với nhiều điều kiện
Giữ đúng lời hứa,
Đây là đáp án của tôi bạn chủ thớt có thể xem, chạy thử trong khi chờ các đáp án khác
Mã: 
Option Explicit

Sub ABC()
Dim i&, j&, Lr&, t&
Dim Arr(), ArrDL(), Res()
Dim Dic As Object, Key, Temp
Dim Sh As Worksheet, Ws As Worksheet
Set Sh = Sheets("DIEU KIEN")
Lr = Sh.Cells(10000, "A").End(xlUp).Row
Arr = Sh.Range("A2:E" & Lr).Value
Set Dic = CreateObject("Scripting.Dictionary")
For i = 1 To UBound(Arr)
    For j = 1 To 3
        Key = Arr(i, j) & "|" & Arr(i, 5) & "|" & Arr(i, 4)
        If Not Dic.Exists(Key) Then t = t + 1: Dic.Add (Key), t
    Next j
Next i
Set Ws = Sheets("DU LIEU")
ArrDL = Ws.Range("A2:E" & Ws.Cells(10000, "A").End(xlUp).Row).Value
ReDim Res(1 To UBound(ArrDL), 1 To 1)
For Each Key In Dic.keys
    Temp = Split(Key, "|")(2)
    For i = 1 To UBound(ArrDL)
        If InStr(1, ArrDL(i, 2), Temp) Then
            If Dic.Exists(ArrDL(i, 1) & "|" & ArrDL(i, 3) & "|" & Temp) Then
                Res(i, 1) = "Y"
            End If
        End If
    Next i
Next Key
Ws.Range("E2").Resize(UBound(ArrDL), 1) = Res
Set Dic = Nothing
MsgBox "Xong"
End Sub

Xem file đính kèm (kết quả đang để ở E2 để đối chiếu với kết quả gốc.
Nhấp chuột vào đây để mở rộng...
Code dùng dic rất hay, chỉnh thêm tí xíu code sẽ hoàn hảo
Thay
If Not Dic.Exists(Key) Then t = t + 1: Dic.Add (Key), t
Bằng
If Not Dic.Exists(Key) Then Dic.Add (Key), Arr(i, 4)
Lúc đó lấy Temp sẽ đơn giản hơn
 
HieuCD đã viết:
Code dùng dic rất hay, chỉnh thêm tí xíu code sẽ hoàn hảo
Thay
If Not Dic.Exists(Key) Then t = t + 1: Dic.Add (Key), t
Bằng
If Not Dic.Exists(Key) Then Dic.Add (Key), Arr(i, 4)
Lúc đó lấy Temp sẽ đơn giản hơn
Nhấp chuột vào đây để mở rộng...
Em thấy nên bỏ cái arr(i,4) ra khỏi key chứ nhỉ nếu nó nằm trong đấy thì cần gì phải thêm câu lệnh Instr.Em chưa code.
 
mraleno đã viết:
Em chào các anh em trong diễn đàn. Hôm nay em có một vấn đề với việc dò tìm dữ liệu.

em có một bảng điều kiện A, B, C (trong đó A có tới 3 cột) và một bảng dữ liệu cũng gồm các cột A, B, C
Điều kiện là: nếu trong bảng dữ liệu dòng nào có dữ liệu giống với 3 cột trong bảng điều kiện thì ở cột "Check" mình điền Y

Cái khó là cột A có tới 3 cột nên em phải ghép lần lượt, còn cột B chỉ cần có chuỗi kí tự trùng với điều kiện là được.

Em làm bằng cách ghép các cột với nhau như hơi dư thừa cột và code chạy rất lâu.

Có anh em nào giúp em bằng code VBA được không? Chân thành cảm ơn
Nhấp chuột vào đây để mở rộng...
Hôm nay rảnh thử viết code bạn thử xem đúng không.
Mã: 
Sub abc()
    Dim i As Long, lr As Long, dic As Object, dk As String, T, arr, j As Integer
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("dieu kien")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:E" & lr).Value
         For i = 1 To UBound(arr)
             For j = 1 To 3
                 dk = arr(i, j) & "#" & arr(i, 5)
                 If Not dic.exists(dk) Then
                    dic.Add dk, arr(i, 4)
                 Else
                    dic.Item(dk) = dic.Item(dk) & "#" & arr(i, 4)
                 End If
              Next j
         Next i
   End With
   With Sheets("du lieu")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 1 Then .Range("D2:D" & lr).ClearContents
        arr = .Range("A2:D" & lr).Value
        For i = 1 To UBound(arr)
            dk = arr(i, 1) & "#" & arr(i, 3)
            If dic.exists(dk) Then
               For Each T In Split(dic.Item(dk), "#")
                   If InStr(arr(i, 2), T) Then
                      arr(i, 4) = "Y"
                      Exit For
                   End If
               Next
            End If
       Next i
       .Range("A2:D" & lr).Value = arr
  End With
  Set dic = Nothing
End Sub
 
snow25 đã viết:
Hôm nay rảnh thử viết code bạn thử xem đúng không.
Mã: 
Sub abc()
    Dim i As Long, lr As Long, dic As Object, dk As String, T, arr, j As Integer
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("dieu kien")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:E" & lr).Value
         For i = 1 To UBound(arr)
             For j = 1 To 3
                 dk = arr(i, j) & "#" & arr(i, 5)
                 If Not dic.exists(dk) Then
                    dic.Add dk, arr(i, 4)
                 Else
                    dic.Item(dk) = dic.Item(dk) & "#" & arr(i, 4)
                 End If
              Next j
         Next i
   End With
   With Sheets("du lieu")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 1 Then .Range("D2:D" & lr).ClearContents
        arr = .Range("A2:D" & lr).Value
        For i = 1 To UBound(arr)
            dk = arr(i, 1) & "#" & arr(i, 3)
            If dic.exists(dk) Then
               For Each T In Split(dic.Item(dk), "#")
                   If InStr(arr(i, 2), T) Then
                      arr(i, 4) = "Y"
                      Exit For
                   End If
               Next
            End If
       Next i
       .Range("A2:D" & lr).Value = arr
  End With
  Set dic = Nothing
End Sub
Nhấp chuột vào đây để mở rộng...
Cách xử lý rất hay, bảng điều kiện thiết kế tuy phức tạp nhưng không có trùng, không cần dùng else và hàm split
 
Dữ liệu ít cột, rút gọn còn 2 vòng for:

PHP: 
Sub Test()
    Dim i As Long, lr As Long, dic As Object, tmp As String, arr
    Set dic = CreateObject("scripting.dictionary")
    With Sheets("Dieu kien")
         lr = .Range("A" & Rows.Count).End(xlUp).Row
         arr = .Range("A2:E" & lr).Value
         For i = 1 To UBound(arr)
                 dic.Item(arr(i, 1) & "#" & arr(i, 5)) = arr(i, 4)
                 dic.Item(arr(i, 2) & "#" & arr(i, 5)) = arr(i, 4)
                 dic.Item(arr(i, 3) & "#" & arr(i, 5)) = arr(i, 4)
         Next i
   End With
   With Sheets("Du lieu")
        lr = .Range("A" & Rows.Count).End(xlUp).Row
        If lr > 1 Then .Range("D2:D" & lr).ClearContents
        arr = .Range("A2:D" & lr).Value
        For i = 1 To UBound(arr)
            tmp = dic.Item(arr(i, 1) & "#" & arr(i, 3))
            If tmp <> "" And InStr(1, arr(i, 2), tmp) > 0 Then arr(i, 4) = "Y"
       Next i
       .Range("A2:D" & lr).Value = arr
  End With
  Set dic = Nothing
End Sub
 
Một cách khác, dùng UDF (Hàm tự tạo)
Ưu điểm: kết quả đặt không cố định, với điều kiện tham chiếu đến vùng gốc là được.
kết cấu hàm check
=check(Vùng điều kiện,dòng chứa dữ liệu)
Cụ thể ô D2 copy xuống
Mã: 
=check('DIEU KIEN'!$A$2:$E$4,A2:C2)

code như sau:
Mã: 
Option Explicit
Function Check(ByVal rng1 As Range, rng2 As Range)
Dim arr(), i&, rng
rng = rng1.Value
ReDim arr(1 To UBound(rng), 1 To 3)
For i = 1 To UBound(rng)
    arr(i, 1) = "-" & rng(i, 1) & "-" & rng(i, 2) & "-" & rng(i, 3) & "-"
    arr(i, 2) = rng(i, 4): arr(i, 3) = rng(i, 5)
Next
rng = rng2.Value
For i = 1 To UBound(arr)
    If arr(i, 1) Like "*-" & rng(1, 1) & "-*" Then
        If rng(1, 2) Like "*" & arr(i, 2) & "*" Then
            If rng(1, 3) = arr(i, 3) Then
                Check = "Y"
                Exit Function
            End If
        End If
    End If
Next
Check = ""
End Function
Capture.JPG
 

File đính kèm

  • MAU DO TIM.xlsb
    15.9 KB · Đọc: 16
cảm ơn anh em đã quan tâm. Đặc biệt cảm ơn các anh em đã chịu khó viết code giúp mình. Qua đó em cũng biết rõ hơn về Dictionary VBA. kết quả đạt được là từ một code em tự viết tốn hơn 1 phút chạy giờ chỉ khoảng 1 đến 5 giây
Cảm ơn các bác @HUONGHCKT , @SA_DQ , @Phuocam, @snow25 , @bebo021999
 
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

hung2412
  • Question
Có Code VBA nào để chỉnh Short date trong Control Panel không? (Ví dụ: Chỉnh dd/mm/yy => dd/mm/yyyy)
Trả lời
2
Đọc
3
ongke0711
ongke0711
S
  • Question
Không lấy đủ dữ liệu bằng kết nối ADO
Trả lời
4
Đọc
123
shnhatha221108
S
H
Nhờ mấy anh chị giúp về công thức dò tìm kiếm và trả về kết quả ngày tháng
Trả lời
2
Đọc
27
SA_DQ
SA_DQ
Bich2B
lỗi định dạng ngày không đọc được công thức excel
Trả lời
7
Đọc
124
tijikama
tijikama
LuuAnh980
  • Question
Code lấy dữ liệu từ 3 file con.
2
Trả lời
35
Đọc
367
LuuAnh980
LuuAnh980
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL Group 1
DIỄN ĐÀN GIẢI PHÁP EXCEL Group 2

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom