Lọc dữ liệu trùng 2 điều kiện. (1 người xem)

[chuot0106]

Tôi có 1 danh sách rất dài khoảng 5000 người, giờ tôi muốn lọc ra từ danh sách này những người có họ tên trùng nhau và ngày tháng năm sinh cũng trùng nhau luôn. Em có File đính kèm và có cả kết quả mong muốn. Nhờ các anh chị và các bạn trên diễn đàn đoạn code có thể thực hiện công việc này.

 

[phihndhsp]

Tôi có 1 danh sách rất dài khoảng 5000 người, giờ tôi muốn lọc ra từ danh sách này những người có họ tên trùng nhau và ngày tháng năm sinh cũng trùng nhau luôn. Em có File đính kèm và có cả kết quả mong muốn. Nhờ các anh chị và các bạn trên diễn đàn đoạn code có thể thực hiện công việc này.

Thử cái này xem sao. file này học ý tưởng từ anh bate

sory đính kèm lộn file file này mới đúng

 

[Quang_Hải]

Tôi có 1 danh sách rất dài khoảng 5000 người, giờ tôi muốn lọc ra từ danh sách này những người có họ tên trùng nhau và ngày tháng năm sinh cũng trùng nhau luôn. Em có File đính kèm và có cả kết quả mong muốn. Nhờ các anh chị và các bạn trên diễn đàn đoạn code có thể thực hiện công việc này.

Bạn tham khảo cách dùng 2 dic

Sub LocTrung()
Dim nguon(), kq(1 To 655536, 1 To 3), i, j, k, tam As String
Dim D1 As Object, D2 As Object
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
nguon = Range([B2], [D65536].End(3)).Value
    For i = 1 To UBound(nguon)
        tam = nguon(i, 1) & nguon(i, 2)
        If Not D1.exists(tam) Then
            D1.Add tam, ""
        Else
            If Not D2.exists(tam) Then D2.Add tam, ""
        End If
    Next
    For i = 1 To UBound(nguon)
        tam = nguon(i, 1) & nguon(i, 2)
        If D2.exists(tam) Then
            k = k + 1
            For j = 1 To 3
                kq(k, j) = nguon(i, j)
            Next
        End If
    Next
If k Then [G1].Resize(k, 3) = kq
End Sub

Nếu dùng 1 Dic thì viết thế này, giống tương tự code bài số 4

Sub LocTrung2()
Dim nguon(), kq(1 To 655536, 1 To 3), i, j, k, tam As String
nguon = Range([B2], [D65536].End(3)).Value
With CreateObject("scripting.dictionary")
    For i = 1 To UBound(nguon)
        tam = nguon(i, 1) & nguon(i, 2)
        If Not .exists(tam) Then
            .Add tam, 1
        Else
            .Item(tam) = 2
        End If
    Next
    For i = 1 To UBound(nguon)
        tam = nguon(i, 1) & nguon(i, 2)
        If .Item(tam) = 2 Then
            k = k + 1
            For j = 1 To 3
                kq(k, j) = nguon(i, j)
            Next
        End If
    Next
End With
If k Then [G1].Resize(k, 3) = kq
End Sub

 

[chuot0106]

sory đính kèm lộn file file này mới đúng

Cảm ơn anh, kết quả chính xác rồi ạ nhưng hình như tốc độ có vẻ hơi chậm anh ạ!

 

[phihndhsp]

ở đây tôi cho mảng dài ra tới 65000 dòng nên nó hơi chậm bạn có thể chọn số dòng theo đúng số dòng hiện tại thì nó sẽ nhanh, bạn có thể co giãn số dòng bằng lệnh ... end(xlup)row

 

[Quang_Hải]

Cảm ơn anh, kết quả chính xác rồi ạ nhưng hình như tốc độ có vẻ hơi chậm anh ạ!

Chậm là vì code bài số 4 lấy tới dòng 65000, bạn có thể sửa lại mà

 

[chuot0106]

ở đây tôi cho mảng dài ra tới 65000 dòng nên nó hơi chậm bạn có thể chọn số dòng theo đúng số dòng hiện tại thì nó sẽ nhanh, bạn có thể co giãn số dòng bằng lệnh ... end(xlup)row

Dạ đúng là sau khi sửa lại code tốc độ nhanh hơn rất nhiều ạ, cảm ơn anh nhiều!

 

[chuot0106]

sory đính kèm lộn file file này mới đúng

Anh có thể viết vài dòng ngắn gọn giải thích thuật toán của bài này giúp em được không ạ? Quả thật là em có đọc code mà vẫn chưa hiểu được ạ!

 

[phihndhsp]

Anh có thể viết vài dòng ngắn gọn giải thích thuật toán của bài này giúp em được không ạ? Quả thật là em có đọc code mà vẫn chưa hiểu được ạ!

Ý nghĩa bài này như sau
Chỉ lấy những phân tử của Dic mà tại vị trí Key của nó có giá trị >1

Lấy từng phần tử trong mảng là key
Kiểm tra nếu key chưa có trong Dis thì gán Dic tại vi trí key đó là 1
If Not Dic.Exists(Tem) Then
Dic.Add Tem, 1
Kiểm tra nếu key đã tồn tại thì Dic tại key đó sẽ tăng lên 1 đơn vị
Else
Dic.Item(Tem) = Dic.Item(Tem) + 1
Vì mình muốn lấy trùng tức là trong Dic có những key có giá trị >1 thì mới lấy còn không thì thôi

If Dic.Item(Tem) >= 2 Then
K = K + 1
For J = 1 To 3
dArr(K, J) = SArr(I, J)
Next J
End If

 

[Lê Duy Thương]

Bạn tham khảo cách dùng 2 dic

Sub LocTrung()
Dim nguon(), kq(1 To 655536, 1 To 3), i, j, k, tam As String
Dim D1 As Object, D2 As Object
Set D1 = CreateObject("scripting.dictionary")
Set D2 = CreateObject("scripting.dictionary")
nguon = Range([B2], [D65536].End(3)).Value
    For i = 1 To UBound(nguon)
        tam = nguon(i, 1) & nguon(i, 2)
        If Not D1.exists(tam) Then
            D1.Add tam, ""
        Else
            If Not D2.exists(tam) Then D2.Add tam, ""
        End If
    Next
    For i = 1 To UBound(nguon)
        tam = nguon(i, 1) & nguon(i, 2)
        If D2.exists(tam) Then
            k = k + 1
            For j = 1 To 3
                kq(k, j) = nguon(i, j)
            Next
        End If
    Next
If k Then [G1].Resize(k, 3) = kq
End Sub

Nếu dùng 1 Dic thì viết thế này, giống tương tự code bài số 4

Sub LocTrung2()
Dim nguon(), kq(1 To 655536, 1 To 3), i, j, k, tam As String
nguon = Range([B2], [D65536].End(3)).Value
With CreateObject("scripting.dictionary")
    For i = 1 To UBound(nguon)
        tam = nguon(i, 1) & nguon(i, 2)
        If Not .exists(tam) Then
            .Add tam, 1
        Else
            .Item(tam) = 2
        End If
    Next
    For i = 1 To UBound(nguon)
        tam = nguon(i, 1) & nguon(i, 2)
        If .Item(tam) = 2 Then
            k = k + 1
            For j = 1 To 3
                kq(k, j) = nguon(i, j)
            Next
        End If
    Next
End With
If k Then [G1].Resize(k, 3) = kq
End Sub

nhìn code cua anh hải mà sử dụng cho bài này thì hơi phí công
tôi thì chỉ cần vầy
ở m2 gõ ct sau

=COUNTIFS($B$2:$B$1129,$B2,$C$2:$C$1129,$C2)>1

và code vba đây

Sub loctrung()
    ActiveSheet.Range("B1:D65536").AdvancedFilter 2, [M1:M2], [M4], False
End Sub

không biết tốc độ thế nào

 

[phihndhsp]

nhìn code cua anh hải mà sử dụng cho bài này thì hơi phí công
tôi thì chỉ cần vầy
ở m2 gõ ct sau

=COUNTIFS($B$2:$B$1129,$B2,$C$2:$C$1129,$C2)>1

và code vba đây

Sub loctrung()
    ActiveSheet.Range("B1:D65536").AdvancedFilter 2, [M1:M2], [M4], False
End Sub

không biết tốc độ thế nào

cái này mà áp dụng trên 60000 dòng sau đó dùng chức năng fiter là cả ngày đó anh

 

[Lê Duy Thương]

cái này mà áp dụng trên 60000 dòng sau đó dùng chức năng fiter là cả ngày đó anh

bạn thử chưa. tôi đã thử 1 triệu dòng file của lão chết tiệt hết 19 giây
đúng là dic nhanh hơn rất nhiều.chỉ có điều hỏng lẽ trùng đến 65000 dòng ta. thế mới phí

 

[phihndhsp]

bạn thử chưa. tôi đã thử 1 triệu dòng file của lão chết tiệt hết 19 giây

chắc do máy em yếu nên chạy rùa, mới thử 1 triệu dòng với 10 cột mà đứng máy nãy giờ rồi

 

[Quang_Hải]

nhìn code cua anh hải mà sử dụng cho bài này thì hơi phí công
tôi thì chỉ cần vầy
ở m2 gõ ct sau

=COUNTIFS($B$2:$B$1129,$B2,$C$2:$C$1129,$C2)>1

và code vba đây

Sub loctrung()
    ActiveSheet.Range("B1:D65536").AdvancedFilter 2, [M1:M2], [M4], False
End Sub

không biết tốc độ thế nào

Ý tưởng hay, vậy đưa luôn vào code cho rồi

Sub loctrung()
    [M2] = "=COUNTIFS(R2C2:R10000C2,RC2,R2C3:R10000C3,RC3)>1"
    Range("B1:D65536").AdvancedFilter 2, [M1:M2], [M4:O4], False
End Sub