Loại bỏ dữ liệu trùng nhau có điều kiện

[hic1802]

Chào mọi người trên GPE,
Nhờ mọi người giúp e tạo VBA chạy lệnh loại bỏ dữ liệu trùng (mã công nhân) trong sheet "ND" theo điều kiện từng ngày trong 1 tháng sang sheet "BC"
Thí dụ : trong sheet "BC", ô A1 = 5 thì lấy dữ liệu từ ngày 2.5.2018 đến 25.5.2018, bằng 4 thì lấy 2.4.2018 đến 29.4.2018
Mọi người xem file excel, sheet "BC" là e đang mới lọc thủ công 2 ngày của tháng 5 (2.5.2018 và 3.5.2018)
Cảm ơn mọi người.

 

[♫ђöล♥ßล†♥†µ♫]

Chào mọi người trên GPE,
Nhờ mọi người giúp e tạo VBA chạy lệnh loại bỏ dữ liệu trùng (mã công nhân) trong sheet "ND" theo điều kiện từng ngày trong 1 tháng sang sheet "BC"
Thí dụ : trong sheet "BC", ô A1 = 5 thì lấy dữ liệu từ ngày 2.5.2018 đến 25.5.2018, bằng 4 thì lấy 2.4.2018 đến 29.4.2018
Mọi người xem file excel, sheet "BC" là e đang mới lọc thủ công 2 ngày của tháng 5 (2.5.2018 và 3.5.2018)
Cảm ơn mọi người.

Em Copy cái Code dưới đưa vào thấy nó đúng với mẫu mỗi ngày 2.5.2018 còn lại trật lất

Sub LOC()
    Dim Dic As Object, Tem As String, Stt As Long
    Dim sArr(), dArr(), I As Long, K As Long, Thang As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("ND")
    sArr = .Range("A4", .Range("B" & Rows.Count).End(3)).Resize(, 10).Value
End With
Thang = Sheets("BC").Range("A1").Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For I = 1 To UBound(sArr, 1)
    If Thang = Val(Split(sArr(I, 1), ".")(1)) Then
        Tem = sArr(I, 1) & "#" & sArr(I, 9) & "#" & sArr(I, 10)
        If I > 1 Then
            If Val(Split(sArr(I, 1), ".")(0)) <> Val(Split(sArr(I - 1, 1), ".")(0)) Then Stt = 0
        End If
        If Not Dic.Exists(Tem) Then
            K = K + 1: Stt = Stt + 1
            Dic.Add Tem, ""
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = Stt
            dArr(K, 3) = UCase(sArr(I, 9))
            dArr(K, 4) = sArr(I, 10)
            dArr(K, 5) = "NO BIET"
        End If
    End If
Next I
Sheets("BC").Range("G3").Resize(K, 5) = dArr
Set Dic = Nothing
End Sub

 

[hic1802]

Em Copy cái Code dưới đưa vào thấy nó đúng với mẫu mỗi ngày 2.5.2018 còn lại trật lất

Sub LOC()
    Dim Dic As Object, Tem As String, Stt As Long
    Dim sArr(), dArr(), I As Long, K As Long, Thang As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("ND")
    sArr = .Range("A4", .Range("B" & Rows.Count).End(3)).Resize(, 10).Value
End With
Thang = Sheets("BC").Range("A1").Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For I = 1 To UBound(sArr, 1)
    If Thang = Val(Split(sArr(I, 1), ".")(1)) Then
        Tem = sArr(I, 1) & "#" & sArr(I, 9) & "#" & sArr(I, 10)
        If I > 1 Then
            If Val(Split(sArr(I, 1), ".")(0)) <> Val(Split(sArr(I - 1, 1), ".")(0)) Then Stt = 0
        End If
        If Not Dic.Exists(Tem) Then
            K = K + 1: Stt = Stt + 1
            Dic.Add Tem, ""
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = Stt
            dArr(K, 3) = UCase(sArr(I, 9))
            dArr(K, 4) = sArr(I, 10)
            dArr(K, 5) = "NO BIET"
        End If
    End If
Next I
Sheets("BC").Range("G3").Resize(K, 5) = dArr
Set Dic = Nothing
End Sub

bác giỏi thiệt, theo e hiểu code của bác thì chỉ cần gán : Tem = sArr(I, 1) & "#" & sArr(I, 9) có hợp lý hay ko bác nhỉ?

 

[hic1802]

Em Copy cái Code dưới đưa vào thấy nó đúng với mẫu mỗi ngày 2.5.2018 còn lại trật lất

Sub LOC()
    Dim Dic As Object, Tem As String, Stt As Long
    Dim sArr(), dArr(), I As Long, K As Long, Thang As Long
Set Dic = CreateObject("Scripting.Dictionary")
With Sheets("ND")
    sArr = .Range("A4", .Range("B" & Rows.Count).End(3)).Resize(, 10).Value
End With
Thang = Sheets("BC").Range("A1").Value
ReDim dArr(1 To UBound(sArr, 1), 1 To 5)
For I = 1 To UBound(sArr, 1)
    If Thang = Val(Split(sArr(I, 1), ".")(1)) Then
        Tem = sArr(I, 1) & "#" & sArr(I, 9) & "#" & sArr(I, 10)
        If I > 1 Then
            If Val(Split(sArr(I, 1), ".")(0)) <> Val(Split(sArr(I - 1, 1), ".")(0)) Then Stt = 0
        End If
        If Not Dic.Exists(Tem) Then
            K = K + 1: Stt = Stt + 1
            Dic.Add Tem, ""
            dArr(K, 1) = sArr(I, 1)
            dArr(K, 2) = Stt
            dArr(K, 3) = UCase(sArr(I, 9))
            dArr(K, 4) = sArr(I, 10)
            dArr(K, 5) = "NO BIET"
        End If
    End If
Next I
Sheets("BC").Range("G3").Resize(K, 5) = dArr
Set Dic = Nothing
End Sub

bác ơi xem hộ em phát sao báo lỗi như thế này nhỉ

 

[♫ђöล♥ßล†♥†µ♫]

Anh đẹp trai hoặc Chị đẹp gái thay cái chỗ màu vàng trong hình bằng If K Then Sheet3.Range("a3").Resize(K, 3) = dArr1 xem sao