LỌC VÀ TÌM KIẾM NHIỀU ĐIỀU KIỆN (1 người xem)

[huonglien1901]

Chào mọi người!

em có hai vấn đề nhờ mọi người hỗ trợ giúp!

Trong file này em có 2 sheet: DATA, KET QUA

Trong sheet kết quả em muốn lọc nhiều tillcode đê lọc lấy ra tất cả dữ liệu thuộc điều kiện đó và vá sắp xếp lại với nhau
Ví dụ một tillcode khi lọc ra hai kết quả lấy hai kết quả đó và khi lấy tiilcode thứ 2 mà tillcode có 3 kết quả thì lấy dữ liệu nằm kế tiếp.
em ví dụ: Tillcode 4306672760102 có hai kết quả được lấy ra.
Và cho biết vị trí kết quả nằm ở dòng nào ở trong sheet DATA.

Em cảm ơn mọi người nhiều!

 

[huonglien1901]

bạn dùng giải thuật nầy để giảm số lần duyệt sArr

Sub Locdulieu1()
    Dim sArr As Variant, dArr As Variant, I As Long, J As Long, K As Long
    Dim Dic As Object, Arr As Variant, Iarr As Variant, Tmp
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("data")
    sArr = .Range("A4", .Range("I" & Rows.Count).End(3)).Value
End With
ReDim dArr(1 To UBound(sArr), 1 To 10)
For I = LBound(sArr, 1) To UBound(sArr, 1)
    Tmp = sArr(I, 2)
    If Not Dic.exists(Tmp) Then
      Dic.Add Tmp, Array(0, I)
    Else
      Arr = Dic.Item(Tmp)
      ReDim Preserve Arr(UBound(Arr) + 1)
      Arr(UBound(Arr)) = I
      Dic(Tmp) = Arr
    End If
Next I
For Each Iarr In Dic.Items()
    For n = 1 To UBound(Iarr)
        K = K + 1
        I = Iarr(n)
        For J = 1 To 9
            dArr(K, J) = sArr(I, J)
        Next J
        dArr(K, 10) = I + 3
    Next n
Next
With Sheets("ket qua")
    If K Then
        .Range("A" & Range("A65535").End(3).Row + 1).Resize(K, 10) = dArr
    Else
        MsgBox "Khong tim thay du lieu"
    End If
End With
End Sub

Dạ cách của Anh code chạy nhanh lắm Anh!

Cảm ơn Anh Hiếu nhiều!