Dung VBA để lọc dữ liệu theo 2 điều kiện cho trước (1 người xem)

[minhcong.tckt]

Em tải file đính kèm, mong các huynh tỷ giúp đỡ
sheet "DK1": Danh mục điều kiện 1
sheet "DK2": Danh mục điều kiện 2
Sheet "DA TA": Sheet nhập dữ liệu thô
Sheet "LOC": Khi chọn điều kiện ở A 2 và B 2 đồng thời thì những dòng bên DA TA thỏa mãn điều kiện sẽ được liệt kê đầy đủ bên "LOC"

Cuối cùng có dòng tổng cộng, NGÀY THÁNG NĂM, LẬP BIỂU

Mong nhận được sự giúp đỡ của các huynh tỷ.

Chân thành cảm ơn!!!

 

[minhcong.tckt]

Bạn cũng có thể nạp list cho Combobox1 bằng phương thức này:

Private Sub ComboBox1_DropButtonClick()
    Call CBBox1
End Sub

và bỏ cách nạp dưới đây thông qua sheet:

Private Sub Worksheet_Activate()
    Call CBBox1
End Sub

Sheet "Loc" của em có thể có thiếu một số cột so với sheet "DATA" thì làm gì để "tủy biến " được ạ
Em muốn đánh trực tiếp mã vào ô I2 và J2 thì làm thế nào ạ?

 

[minhcong.tckt]

Bên sheet "Loc" ko lọc phần ghi chú bên sheet "Data" thì sửa code như thế nào hả anh

 

[minhcong.tckt]

Hổm rầy cứ Dit to, Dit nhỏ hoài mệt quá roài, giờ không muốn Dit nữa mà mượn các hàm tự tạo của Thầy ndu96081631 làm luôn cho bạn này chơi!

Thủ tục cho 2 combobox:

[COLOR=#006400]'Nap List cho combobox1 khi sheet duoc Active[/COLOR]
Private Sub Worksheet_Activate()
    Call CBBox1
End Sub

[COLOR=#006400]'Nap List cho combobox2 khi ComboBox1 thay doi va chi loc theo Ma o ComboBox1[/COLOR]
Private Sub ComboBox1_Change()
    Call CBBox2
End Sub

Sub CBBox1()
    Dim sArray
    sArray = Range(Sheet3.[H7], Sheet3.[H65536].End(xlUp)).Value
    Sheet4.ComboBox1.List() = Unique2DArray(sArray, 1, False)
End Sub

Sub CBBox2()
    On Error GoTo ExitSub
    Dim sArray, MyArr, i As Long
    With Sheet4.ComboBox2
        .Clear
        .Text = ""
        sArray = Range(Sheet3.[H7], Sheet3.[I65536].End(xlUp)).Value
        sArray = Filter2DArray(sArray, 1, Sheet4.ComboBox1, False)
        sArray = Unique2DArray(sArray, 2, False)
        ReDim MyArr(1 To UBound(sArray), 1 To 1)
        For i = 1 To UBound(sArray)
            MyArr(i, 1) = sArray(i, 2)
        Next
        .List() = MyArr: Exit Sub
ExitSub:
        .Clear
    End With
End Sub

Thủ tục cho nút lệnh:

Sub CmdBtt1()
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
        On Error GoTo ExitSub
        Dim sArray, MyArr, i As Long, j As Long
        Call TestRow
        sArray = Range(Sheet3.[B7], Sheet3.[I65536].End(xlUp)).Value
        sArray = Filter2DArray(sArray, 7, Sheet4.ComboBox1, False)
        sArray = Filter2DArray(sArray, 8, Sheet4.ComboBox2, False)
        ReDim MyArr(1 To UBound(sArray), 1 To 6)
        For i = 1 To UBound(sArray)
            MyArr(i, 1) = i
            For j = 1 To 5
                MyArr(i, j + 1) = sArray(i, j)
            Next
        Next
            
       [COLOR=#006400] 'Thu tuc kiem tra so hàng truoc khi nhap lieu:[/COLOR]
        With Sheet4
            i = UBound(MyArr)
            If i > 12 Then
                i = i - 13
                .Range("A9:G" & 9 + i).Insert 2
            End If
        End With
        Sheet4.Range("A8").Resize(UBound(MyArr), 6).Value = MyArr
ExitSub:
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Và đương nhiên phải kiểm tra điều kiện "phòng ốc" trước chứ:

Sub TestRow()
    Dim i As Long
    With Sheet4
        i = Range("Cong").Row
        If i > 20 Then
            i = i - 21
            .Range("A9:G" & 9 + i).Delete 2
        ElseIf i < 20 Then
            i = 19 - i
            .Range("A9:G" & 9 + i).Insert 2
        End If
        .Range("A8:G19").ClearContents
    End With
End Sub

Lưu ý: Tại ô B20 tôi đặt name là Cong.

Bác giúp em thêm 1 vấn đề nữa, tại sheet "DATA: trong một số ô có viết "comment", giờ làm thế nào để mang cả "comment" đó theo sang bên sheet LOC ạ