Nhờ sửa mã tìm kiếm theo điều kiện!

theanhst92 · 19/12/20

Kính gửi mọi người. em có sử dụng mã sau để tìm kiếm nhiều điều kiện cho bảng dữ liệu. giờ mong các bác sửa giúp để có thể lấy thêm giá trị cho điều kiện. mong mọi người sửa giúp em với ạ.
Em xin được cảm ơn ạ!
Hình 1. dữ liệu

Hình 2: kết quả

Mã:

Sub TimsoKH()
Dim i, j As Long, Dic As Object, ArrDL, ArrKH, Kq, DK As String
Set Dic = CreateObject("Scripting.dictionary")
ArrDL = Sheet1.Range("B2:H" & Sheet1.[B65536].End(3).Row)
ArrKH = Sheet12.Range("A3:F" & Sheet12.[A65536].End(3).Row)
    With Sheet1
        ReDim Kq(1 To UBound(ArrDL), 1 To 1)
        For i = 1 To UBound(ArrKH)
            DK = ArrKH(i, 1) & "#" & ArrKH(i, 3)
            If Not Dic.Exists(DK) Then
               Dic.Add DK, ArrKH(i, 4)
            Else
               Dic.Item(DK) = Dic.Item(DK) + ArrKH(i, 4)
            End If
        Next i
        For i = 1 To UBound(ArrDL)
             DK = ArrDL(i, 1) & "#" & ArrDL(i, 2)
             Kq(i, 1) = Dic.Item(DK)
        On Error Resume Next
        Next i
       
    End With
Set Dic = Nothing
Sheet1.[D2].Resize(i, 1).Value = Kq
End Sub

Cu Tồ · 19/12/20

Bài này thì nên lọc ra một mảng hoặc là chạy hai vòng lặp,vì code hiện tại của bạn dùng item để chưa kết quả thì các cột còn lại không lấy được
mà cho cái On Error Resume Next này vào có nguye hiểm không,làm sao kiểm soát được lỗi khi mà cứ sai nó bỏ qua hết

theanhst92 đã viết:
On Error Resume Next

Cu Tồ · 19/12/20

Mã:

Option Explicit

Sub test()
Dim Arr(), KQ()
Dim Dk As String, i As Long, K As Long
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")

With Sheet1
    Arr = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Resize(, 2).Value
    ReDim KQ(1 To UBound(Arr), 1 To 3)
    For i = 1 To UBound(Arr)
            Dk = Arr(i, 1) & Arr(i, 2)
        If Not Dic.Exists(Dk) Then Dic.Add Dk, i
    Next
End With
With Sheet12
    Arr = .Range("A3", .Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value
    For i = 1 To UBound(Arr)
            Dk = Arr(i, 1) & Arr(i, 3)
        If Dic.Exists(Dk) Then
                K = Dic.Item(Dk)
            KQ(K, 1) = KQ(K, 1) + Arr(i, 4)
            KQ(K, 2) = KQ(K, 2) + Arr(i, 5)
            KQ(K, 3) = KQ(K, 3) + Arr(i, 6)
        End If
    Next
End With
Sheets("Sheet3").Range("D2").Resize(K, 3) = KQ
End Sub

Hoặc bạn thử code này

theanhst92 · 20/12/20

Cu Tồ đã viết:

Mã:

Option Explicit

Sub test()
Dim Arr(), KQ()
Dim Dk As String, i As Long, K As Long
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")

With Sheet1
    Arr = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Resize(, 2).Value
    ReDim KQ(1 To UBound(Arr), 1 To 3)
    For i = 1 To UBound(Arr)
            Dk = Arr(i, 1) & Arr(i, 2)
        If Not Dic.Exists(Dk) Then Dic.Add Dk, i
    Next
End With
With Sheet12
    Arr = .Range("A3", .Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value
    For i = 1 To UBound(Arr)
            Dk = Arr(i, 1) & Arr(i, 3)
        If Dic.Exists(Dk) Then
                K = Dic.Item(Dk)
            KQ(K, 1) = KQ(K, 1) + Arr(i, 4)
            KQ(K, 2) = KQ(K, 2) + Arr(i, 5)
            KQ(K, 3) = KQ(K, 3) + Arr(i, 6)
        End If
    Next
End With
Sheets("Sheet3").Range("D2").Resize(K, 3) = KQ
End Sub

Hoặc bạn thử code này

em xin cảm ơn ạ. mã này chạy quá ngon bác ạ! am gà gô học mót ít vba nên không biết cách triển khai thế nào. nhìn mã thì hiểu nhưng k biết cách tự viết.

Cu Tồ · 20/12/20

theanhst92 đã viết:
em xin cảm ơn ạ. mã này chạy quá ngon bác ạ! am gà gô học mót ít vba nên không biết cách triển khai thế nào. nhìn mã thì hiểu nhưng k biết cách tự viết.

ở phần sheet1 vì là lấy dữ liệu điều kiện để tìm kiếm nên các dòng điều điện ở đây là duy nhất nha (nhưng chắc dữ liệu của bạn cũng là duy nhất,vì tôi xem trong file dữ liệu điều kiện là duy nhất không có trùng lặp nên chọn cách này).chỉ có điểm lưu ý đó thôi

theanhst92 · 20/12/20

Cu Tồ đã viết:
ở phần sheet1 vì là lấy dữ liệu điều kiện để tìm kiếm nên các dòng điều điện ở đây là duy nhất nha (nhưng chắc dữ liệu của bạn cũng là duy nhất,vì tôi xem trong file dữ liệu điều kiện là duy nhất không có trùng lặp nên chọn cách này).chỉ có điểm lưu ý đó thôi

ồ. vậy thì lại không được rồi ạ, em chưa xem kỹ. dữ liệu của em tại sheet 1 là sheet nhập liệu cho nên các mã sẽ phát sinh nhiều lần. lặp đi lặp lại bất kỳ lúc nào. nhờ bác có thể sửa lại giúp em với ạ!

Cu Tồ · 20/12/20

theanhst92 đã viết:
ồ. vậy thì lại không được rồi ạ, em chưa xem kỹ. dữ liệu của em tại sheet 1 là sheet nhập liệu cho nên các mã sẽ phát sinh nhiều lần. lặp đi lặp lại bất kỳ lúc nào. nhờ bác có thể sửa lại giúp em với ạ!

tôi không nói các mã đó mà là các điều kiện cơ,chỉ cần các điều kiện bên sheets này không trùng lặp là được,vì nếu như trùng nhau thì kết quả vẫn thế

ví dụ hai mã trùng nhau thì sẽ lấy một kết quả vì có lấy hai kết quả thì nó cũng như nhau,còn dữ liệu ở sheets bên canh thì trùng hay thêm như thế nào thoải mái

theanhst92 · 20/12/20

Cu Tồ đã viết:
tôi không nói các mã đó mà là các điều kiện cơ,chỉ cần các điều kiện bên sheets này không trùng lặp là được,vì nếu như trùng nhau thì kết quả vẫn thế
View attachment 251533
ví dụ hai mã trùng nhau thì sẽ lấy một kết quả vì có lấy hai kết quả thì nó cũng như nhau,còn dữ liệu ở sheets bên canh thì trùng hay thêm như thế nào thoải mái
View attachment 251534

ý em là kết quả vẫn thế nhưng nó k tìm được cho các dòng phía sau ạ.
em đang muốn như sau ạ!

Cu Tồ · 21/12/20

theanhst92 đã viết:
k tìm được cho các dòng phía sau

Mã:

Option Explicit

Sub test()
Dim Arr(), KQ(), TH()
Dim DK As String, i As Long, K As Long, Rws As Long
Dim Dic As Object
Set Dic = CreateObject("Scripting.dictionary")

With Sheet12
    Arr = .Range("A3", .Range("A" & Rows.Count).End(xlUp)).Resize(, 6).Value
    ReDim TH(1 To UBound(Arr), 1 To 5)
    For i = 1 To UBound(Arr)
            DK = Trim(Arr(i, 1)) & Trim(Arr(i, 3))
        If Not Dic.Exists(DK) Then
                K = K + 1
            Dic.Add DK, K
                TH(K, 1) = Arr(i, 1)
                TH(K, 2) = Arr(i, 3)
                TH(K, 3) = Arr(i, 4)
                TH(K, 4) = Arr(i, 5)
                TH(K, 5) = Arr(i, 6)
         Else
                Rws = Dic.Item(DK)
                TH(Rws, 3) = TH(Rws, 3) + Arr(i, 4)
                TH(Rws, 4) = TH(Rws, 4) + Arr(i, 5)
                TH(Rws, 5) = TH(Rws, 5) + Arr(i, 6)
         End If
    Next
End With
With Sheet1
    Arr = .Range("B2", .Range("B" & Rows.Count).End(xlUp)).Resize(, 5).Value
    ReDim KQ(1 To UBound(Arr), 1 To 5)
    For i = 1 To UBound(Arr)
            DK = Trim(Arr(i, 1)) & Trim(Arr(i, 2))
        If Dic.Exists(DK) Then
                K = Dic.Item(DK)
            KQ(i, 1) = TH(K, 1)
            KQ(i, 2) = TH(K, 2)
            KQ(i, 3) = TH(K, 3)
            KQ(i, 4) = TH(K, 4)
            KQ(i, 5) = TH(K, 5)
        End If
    Next
End With
Sheets("Sheet3").Range("B2").Resize(UBound(Arr), 5).ClearContents
Sheets("Sheet3").Range("B2").Resize(UBound(Arr), 5) = KQ
End Sub

Thử code này

theanhst92 · 21/12/20

Em cảm ơn bác đã nhiệt tình giúp em ạ. mã trên đã chạy ổn nhưng em có thắc mặc đoạn sau không biết có tác dụng gì. vì khi xem xoá bỏ nó đi vẫn thấy chạy đúng!

Mã:

        Else
                Rws = Dic.Item(DK)
                TH(Rws, 3) = TH(Rws, 3) + Arr(i, 4)
                TH(Rws, 4) = TH(Rws, 4) + Arr(i, 5)
                TH(Rws, 5) = TH(Rws, 5) + Arr(i, 6)
         End If

Cu Tồ · 21/12/20

theanhst92 đã viết:
Em cảm ơn bác đã nhiệt tình giúp em ạ. mã trên đã chạy ổn nhưng em có thắc mặc đoạn sau không biết có tác dụng gì. vì khi xem xoá bỏ nó đi vẫn thấy chạy đúng!

Mã:

Else Rws = Dic.Item(DK) TH(Rws, 3) = TH(Rws, 3) + Arr(i, 4) TH(Rws, 4) = TH(Rws, 4) + Arr(i, 5) TH(Rws, 5) = TH(Rws, 5) + Arr(i, 6) End If

Đoạn này là tôi dự phòng khi mà cái danh sách bên kia của bạn có trùng lặp thì nó sẽ tính tổng,để tránh gặp lỗi lại phải sửa code cho bạn thôi.Nếu danh sách là duy nhất bỏ nó đi hoặc không bỏ cũng không sao

theanhst92 · 21/12/20

Cu Tồ đã viết:
Đoạn này là tôi dự phòng khi mà cái danh sách bên kia của bạn có trùng lặp thì nó sẽ tính tổng,để tránh gặp lỗi lại phải sửa code cho bạn thôi.Nếu danh sách là duy nhất bỏ nó đi hoặc không bỏ cũng không sao

à em hiểu rồi ạ. em cảm ơn ạ!

Nhờ sửa mã tìm kiếm theo điều kiện!

theanhst92

Thành viên hoạt động

File đính kèm

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

theanhst92

Thành viên hoạt động

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

theanhst92

Thành viên hoạt động

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

theanhst92

Thành viên hoạt động

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

theanhst92

Thành viên hoạt động

Cu Tồ

Tìm đến kiến thức! ꧁༺ Cu Tồ ༻꧂

theanhst92

Thành viên hoạt động

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

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