Xin giúp đỡ viết hàm tìm kiếm giá trị theo điều kiện!

[theanhst92]

Kính thưa thầy cô, anh chị trong diễn đàn!
Em đang muốn viết một hàm để tìm kiếm giá trị theo điều kiện. dữ liệu đưa vào là theo chiều dọc. sau khi tìm kiếm xong sẽ ghi dữ liệu tìm kiếm được theo chiều ngang. em xin phép gửi file và ảnh mô phỏng nội dung muốn thực hiện. mong được mọi người giúp đỡ. em xin cảm ơn ạ!

 

[DUNGHOA1963]

Em xem công thức trong file nhé.

 

[Thóc Sama]

Kính thưa thầy cô, anh chị trong diễn đàn!
Em đang muốn viết một hàm để tìm kiếm giá trị theo điều kiện. dữ liệu đưa vào là theo chiều dọc. sau khi tìm kiếm xong sẽ ghi dữ liệu tìm kiếm được theo chiều ngang. em xin phép gửi file và ảnh mô phỏng nội dung muốn thực hiện. mong được mọi người giúp đỡ. em xin cảm ơn ạ!
View attachment 281734

Bạn thử code sau xem đúng không?

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("K3:L3")) Is Nothing Then
        Dim i As Long, j As Long, Arr(), Res(), a As Long
        Dim Kho As String, Mahang As String, Lr As Long, k As Long
        On Error Resume Next
        With Sheets("Sheet1")
            .Range("M3:AA10000") = ""
            Kho = UCase(.Range("K3").Value)
            Mahang = UCase(.Range("L3").Value)
            Lr = .Range("B" & Rows.Count).End(xlUp).Row
            Arr = .Range("B3:H" & Lr).Value
            ReDim Res(1 To UBound(Arr) * 3, 1 To UBound(Arr))
            For i = 1 To UBound(Arr)
                If UCase(Arr(i, 1)) = Kho Then
                    If UCase(Arr(i, 2)) = Mahang Then
                        k = k + 1
                        For a = 1 To 4
                            Res(1, a) = Arr(i, a + 3)
                        Next a
                    End If
                End If
                .Cells(3, 12 + k).Resize(4, k).Value = Application.Transpose(Res)
            Next i
        End With
    End If
End Sub

 

[theanhst92]

Bạn thử code sau xem đúng không?

Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("K3:L3")) Is Nothing Then
        Dim i As Long, j As Long, Arr(), Res(), a As Long
        Dim Kho As String, Mahang As String, Lr As Long, k As Long
        On Error Resume Next
        With Sheets("Sheet1")
            .Range("M3:AA10000") = ""
            Kho = UCase(.Range("K3").Value)
            Mahang = UCase(.Range("L3").Value)
            Lr = .Range("B" & Rows.Count).End(xlUp).Row
            Arr = .Range("B3:H" & Lr).Value
            ReDim Res(1 To UBound(Arr) * 3, 1 To UBound(Arr))
            For i = 1 To UBound(Arr)
                If UCase(Arr(i, 1)) = Kho Then
                    If UCase(Arr(i, 2)) = Mahang Then
                        k = k + 1
                        For a = 1 To 4
                            Res(1, a) = Arr(i, a + 3)
                        Next a
                    End If
                End If
                .Cells(3, 12 + k).Resize(4, k).Value = Application.Transpose(Res)
            Next i
        End With
    End If
End Sub

em xin cảm ơn bác đã quan tâm và giúp đỡ ạ. code của bác về cơ bản đã chạy theo đúng mong muốn của em. nhưng khi em áp dụng nó vào file của em với dữ liệu lơn thì thấy nó chạy bị chậm nên em đã thử sử dụng dictionary để dùng theo code của bác nhưng nó lại không được như mong muốn, do hiểu biết của em có hạn nên hy vọng bác sửa lại giúp em với ạ. em xin cảm ơn ạ!

Sub TIMTH()
Dim Arr()
Dim dic As Object, i As Long, j As Long, k As Long, n As Byte, DK
Dim Kho As String, Mahang As String
Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
    Arr = Sheet1.Range("B3", Sheet1.Range("B" & Rows.Count).End(xlUp)).Resize(, 7).Value
    ReDim KQ(1 To UBound(Arr) * 3, 1 To UBound(Arr))
    For i = 1 To UBound(Arr)
        Kho = UCase(Sheet1.Range("K3").Value)
        Mahang = UCase(Sheet1.Range("L3").Value)
        DK = Kho & Mahang
            If Not IsEmpty(DK) And Not dic.exists(DK) Then
                dic.Add DK, k
                k = k + 1
                For j = 1 To 4
                    KQ(1, j) = Arr(i, j + 3)
                Next
            End If
    Next
Sheet1.Range("M3").Resize(1, k + 15).Value = KQ
End Sub

 

[snow25]

em xin cảm ơn bác đã quan tâm và giúp đỡ ạ. code của bác về cơ bản đã chạy theo đúng mong muốn của em. nhưng khi em áp dụng nó vào file của em với dữ liệu lơn thì thấy nó chạy bị chậm nên em đã thử sử dụng dictionary để dùng theo code của bác nhưng nó lại không được như mong muốn, do hiểu biết của em có hạn nên hy vọng bác sửa lại giúp em với ạ. em xin cảm ơn ạ!

Sub TIMTH()
Dim Arr()
Dim dic As Object, i As Long, j As Long, k As Long, n As Byte, DK
Dim Kho As String, Mahang As String
Set dic = CreateObject("scripting.dictionary")
Application.ScreenUpdating = False
    Arr = Sheet1.Range("B3", Sheet1.Range("B" & Rows.Count).End(xlUp)).Resize(, 7).Value
    ReDim KQ(1 To UBound(Arr) * 3, 1 To UBound(Arr))
    For i = 1 To UBound(Arr)
        Kho = UCase(Sheet1.Range("K3").Value)
        Mahang = UCase(Sheet1.Range("L3").Value)
        DK = Kho & Mahang
            If Not IsEmpty(DK) And Not dic.exists(DK) Then
                dic.Add DK, k
                k = k + 1
                For j = 1 To 4
                    KQ(1, j) = Arr(i, j + 3)
                Next
            End If
    Next
Sheet1.Range("M3").Resize(1, k + 15).Value = KQ
End Sub

Nếu dùng dictionary ở trong trường hợp này nên khai báo biến Private hoặc Public với dictionary và mảng để chạy dữ liệu lớn chứ.1 giá trị thì dùng dic với không dic nó cũng như nhau à.

 

[bebo021999]

Một cách khác không dùng vòng lặp có thể làm code nhanh hơn. Sau khi chạy code, bảng gốc sẽ sort lại theo mã kho và mã hàng.
Thay đổi giá trị tại 1 trong 2 ô K3 và L3:

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim lr&, r1&, r2&, cellR As Range
Application.ScreenUpdating = False
If Intersect(Target, Range("K3:L3")) Is Nothing Then Exit Sub
lr = Cells(Rows.Count, "B").End(xlUp).Row
With Range("B3:H" & lr)
    .Sort Range("B2"), , Range("C2") ' sort theo makho va mahang
    r1 = Evaluate("=MATCH(K3 & "" - "" & L3,B3:B" & lr & " & "" - "" & C3:C" & lr & ",0)") ' tim dong dau tien
    r2 = Evaluate("=COUNTIFS(B3:B" & lr & ",K3,C3:C" & lr & ",L3)") ' tim dong cuoi cung
    Set cellR = Range("E2").Offset(r1, 0).Resize(r2, 4) ' vung loai hang va so luong tuong ung
End With
Range("M3:S10000").ClearContents
cellR.Copy 'copy vung va dan vao vung tu o M3, hang thanh cot va cot thanh hang
Range("M3").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=True
Application.CutCopyMode = False
Range("K2").Select
Application.ScreenUpdating = True
End Sub

 

[huuthang_bd]

Công cụ có sẵn ngon lành vậy sao không dùng nhỉ.

 

[Phương Thanh103]

Em xem công thức trong file nhé.

Mình thấy như trong file này là ok rồi mà.

 

[DUNGHOA1963]

Công cụ có sẵn ngon lành vậy sao không dùng nhỉ.
View attachment 281769

Anh dùng công cụ gì vậy ah? Nếu Pivot Table thì em tham khảo file với.

 

[huuthang_bd]

Anh dùng công cụ gì vậy ah? Nếu Pivot Table thì em tham khảo file với.

Là Pivot Table đó bạn.

 

[DUNGHOA1963]

Là Pivot Table đó bạn.

Cảm ơn anh, giờ em mới để ý Values có thể kéo ra rows như vậy.