Hỗ trợ chỉnh lại code VBA (1 người xem)

[dinhquang042000]

Kính gửi các anh/chị FORUMS,
Báo cáo của em, em Lọc dữ liệu từ Sheet TH3 có cột A (số Conts) trùng nhau thỏa mãn các điều kiện phía sau: VD: điều kiện cột D, Cột H, Cột J thoải mãn điều kiện) và coppy sang các sheet tương ứng, qua tìm hiểu trên diễn đàn và nhờ anh chị giúp đỡ, Em đang dùng code VBA dưới (file đính kèm)
Nhưng do giá trị conts có thể cùng phương án nhưng làm nhiều lần trong tháng, khi chạy code này, nó chỉ lấy theo phương án trên cùng.
Em muốn chỉnh sửa lại code để có thêm điều kiện khi lọc là Cột E (Ngày) có giá trị phải trùng nhau.
Mong các anh chị bớt chút thời gian chỉ giáo thêm giúp e.
Em xin chân thành cảm ơn.

Sub GPEPARURU()
Dim Darr, arrDO(), arrNH(), arrNT(), arrNS(), arrHS(), arrND(), arrDI(), arrDO_NH(), arrDO_NT(), arrDO_NS(), arrDO_HS(), arrDO_ND(), arrDO_DI(), Dic As Object
Dim i As Long, K As Long, nNH As Long, nNT As Long, nHS As Long, nNS As Long, nND As Long, nDI As Long, J As Integer
Set Dic = CreateObject("Scripting.Dictionary")
Darr = Sheets("TH3").Range("A1:J" & Sheets("TH3").Range("A2").End(xlDown).Row)
ReDim arrDO(1 To UBound(Darr), 1 To 10): ReDim arrNH(1 To UBound(Darr), 1 To 10)
ReDim arrNT(1 To UBound(Darr), 1 To 10): ReDim arrNS(1 To UBound(Darr), 1 To 10)
ReDim arrHS(1 To UBound(Darr), 1 To 10): ReDim arrND(1 To UBound(Darr), 1 To 10)
ReDim arrDI(1 To UBound(Darr), 1 To 10)
ReDim arrDO_NH(1 To UBound(Darr), 1 To 10)
ReDim arrDO_NT(1 To UBound(Darr), 1 To 10)
ReDim arrDO_NS(1 To UBound(Darr), 1 To 10)
ReDim arrDO_HS(1 To UBound(Darr), 1 To 10)
ReDim arrDO_ND(1 To UBound(Darr), 1 To 10)
ReDim arrDO_DI(1 To UBound(Darr), 1 To 10)

For J = 1 To 10
    arrDO(1, J) = Darr(1, Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
    arrNH(1, J) = arrDO(1, J): arrDO_NH(1, J) = arrDO(1, J)
    arrNT(1, J) = arrDO(1, J): arrDO_NT(1, J) = arrDO(1, J)
    arrNS(1, J) = arrDO(1, J): arrDO_NS(1, J) = arrDO(1, J)
    arrHS(1, J) = arrDO(1, J): arrDO_HS(1, J) = arrDO(1, J)
    arrND(1, J) = arrDO(1, J): arrDO_ND(1, J) = arrDO(1, J)
    arrDI(1, J) = arrDO(1, J): arrDO_DI(1, J) = arrDO(1, J)
    
Next J
K = 1: nNH = 1: nNT = 1: nNS = 1: nHS = 1
For i = 2 To UBound(Darr)
    If Darr(i, 8) = "RURU" And Darr(i, 4) = "F" And Darr(i, 10) = Sheets("BAO CAO").Range("D4").Value Then
        K = K + 1
        For J = 1 To 10
            arrDO(K, J) = Darr(i, Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
        Next J
        If Not Dic.Exists(arrDO(K, 1)) Then Dic.Add arrDO(K, 1), ""
    End If
    If Darr(i, 8) = "HBCX" And Darr(i, 4) = "F" Then
        nNH = nNH + 1
        For J = 1 To 10
            arrNH(nNH, J) = Darr(i, Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
        Next J
    End If
     If Darr(i, 8) = "HANG" And Darr(i, 4) = "F" Then
        nNT = nNT + 1
        For J = 1 To 10
            arrNH(nNT, J) = Darr(i, Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
        Next J
    End If
    If Darr(i, 8) = "HSLA" And Darr(i, 4) = "F" Then
        nHS = nHS + 1
        For J = 1 To 10
            arrNH(nHS, J) = Darr(i, Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
        Next J
    End If
    If Darr(i, 8) = "NSLC" And Darr(i, 4) = "F" Then
        nNS = nNS + 1
        For J = 1 To 10
            arrNS(nNS, J) = Darr(i, Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
        Next J
    End If
    If Darr(i, 8) = "HBND" And Darr(i, 4) = "F" Then
        nNS = nNS + 1
        For J = 1 To 10
            arrNS(nNS, J) = Darr(i, Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
        Next J
    End If
    If Darr(i, 8) = "DI" And Darr(i, 4) = "F" Then
        nDI = nDI + 1
        For J = 1 To 10
            arrDI(nDI, J) = Darr(i, Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10))
        Next J
    End If

Next i
K = 1
For i = 2 To nNH
    If Dic.Exists(arrNH(i, 1)) Then
        K = K + 1
        For J = 1 To 10
            arrDO_NH(K, J) = arrNH(i, J)
        Next J
    End If
Next i
With Sheets("HBCX - RURU")
    .Range("A1:J" & .Range("A500000").End(xlUp).Row).ClearContents
    .Range("A1").Resize(K + 1, 10) = arrDO_NH
End With
K = 1
For i = 2 To nNT
    If Dic.Exists(arrNT(i, 1)) Then
        K = K + 1
        For J = 1 To 10
            arrDO_NT(K, J) = arrNT(i, J)
        Next J
    End If
Next i
With Sheets("HANG - RURU")
    .Range("A1:J" & .Range("A500000").End(xlUp).Row).ClearContents
    .Range("A1").Resize(K + 1, 10) = arrDO_NT
End With
K = 1
For i = 2 To nNS
    If Dic.Exists(arrNS(i, 1)) Then
        K = K + 1
        For J = 1 To 10
            arrDO_NS(K, J) = arrNS(i, J)
        Next J
    End If
Next i
With Sheets("NSLC - RURU")
    .Range("A1:J" & .Range("A500000").End(xlUp).Row).ClearContents
    .Range("A1").Resize(K + 1, 10) = arrDO_NS
End With
K = 1
For i = 2 To nHS
    If Dic.Exists(arrHS(i, 1)) Then
        K = K + 1
        For J = 1 To 10
            arrDO_HS(K, J) = arrHS(i, J)
        Next J
    End If
Next i
With Sheets("HSLA - RURU")
    .Range("A1:J" & .Range("A500000").End(xlUp).Row).ClearContents
    .Range("A1").Resize(K + 1, 10) = arrDO_HS
End With
K = 1
For i = 2 To nND
    If Dic.Exists(arrND(i, 1)) Then
        K = K + 1
        For J = 1 To 10
            arrDO_ND(K, J) = arrND(i, J)
        Next J
    End If
Next i
With Sheets("HBND - RURU")
    .Range("A1:J" & .Range("A500000").End(xlUp).Row).ClearContents
    .Range("A1").Resize(K + 1, 10) = arrDO_ND
End With
K = 1
For i = 2 To nDI
    If Dic.Exists(arrDI(i, 1)) Then
        K = K + 1
        For J = 1 To 10
            arrDO_DI(K, J) = arrDI(i, J)
        Next J
    End If
Next i
With Sheets("NTAU - RURU")
    .Range("A1:J" & .Range("A500000").End(xlUp).Row).ClearContents
    .Range("A1").Resize(K + 1, 10) = arrDO_DI
End With
Set Dic = Nothing
End Sub

 

[befaint]

Thay toàn bộ

Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)

bằng

J

 

[dinhquang042000]

Thay toàn bộ

Choose(J, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10)

bằng

J

Thay cái này là lọc trùng ở 2 cột A và Cột E, các cột khác sẽ lấy theo điều kiện hay là lọc trùng ở tất cả các cột ạ.
Mong anh chỉ giáo ạ.