Tìm dữ liệu trùng và liệt kê ra

[Phương Phương mito]

Kính gửi Anh chị và các bạn,
Em có File sau là số theo dõi bán hàng. Trong đó cột SĐT nhiều khi bị nhầm lẫn một số ĐT có thể bị nhập trùng vào nhiều khác hàng. Em muốn dùng VBA để list ra cá KH trùng số điện thoại như ở Sheet Ketqua thì làm sao ạ (Mỗi một List trùng số điện thoại cách nhau một khoảng trống cho dễ nhìn ạ). Em cảm ơn ạ !

 

[Ba Tê]

Kính gửi Anh chị và các bạn,
Em có File sau là số theo dõi bán hàng. Trong đó cột SĐT nhiều khi bị nhầm lẫn một số ĐT có thể bị nhập trùng vào nhiều khác hàng. Em muốn dùng VBA để list ra cá KH trùng số điện thoại như ở Sheet Ketqua thì làm sao ạ (Mỗi một List trùng số điện thoại cách nhau một khoảng trống cho dễ nhìn ạ). Em cảm ơn ạ !

Format cột G là Text rồi chạy thử Sub này nhé, chạy lòng vòng cho vui, kết quả cũng khác với mẫu.

Public Sub s_Gpe()
Dim sArr(), dArr(), tArr(), Tmp As Variant
Dim I As Long, J As Long, K As Long, K2 As Long, R As Long, Rws As Long
Dim Txt1 As String, Txt2 As String
    sArr = Sheets("Du lieu").Range("C2", Sheets("Du lieu").Range("C2").End(xlDown)).Resize(, 5).Value
    R = UBound(sArr)
ReDim tArr(1 To R, 1 To 2)
ReDim dArr(1 To R, 1 To 3)
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Txt1 = sArr(I, 5)
        Txt2 = sArr(I, 1) & "#" & sArr(I, 5)
        If Not .Exists(Txt1) Then
            K = K + 1
            .Item(Txt1) = K
            tArr(K, 1) = sArr(I, 5)
            If Not .Exists(Txt2) Then
                .Item(Txt2) = ""
                tArr(K, 2) = I
            End If
        Else
            Rws = .Item(Txt1)
            If Not .Exists(Txt2) Then
                .Item(Txt2) = ""
                tArr(Rws, 2) = tArr(Rws, 2) & ";" & I
            End If
        End If
    Next I
End With
For I = 1 To K
    If InStr(tArr(I, 2), ";") Then
        Tmp = Split(tArr(I, 2), ";")
        For J = 0 To UBound(Tmp)
            K2 = K2 + 1
            dArr(K2, 1) = tArr(I, 1)
            dArr(K2, 2) = sArr(Tmp(J), 1)
            dArr(K2, 3) = sArr(Tmp(J), 2)
        Next J
        K2 = K2 + 1
    End If
Next I
Sheets("ketqua").Range("G3").Resize(R, 3).ClearContents
Sheets("ketqua").Range("G3").Resize(K2, 3) = dArr
End Sub

 

[Phương Phương mito]

Format cột G là Text rồi chạy thử Sub này nhé, chạy lòng vòng cho vui, kết quả cũng khác với mẫu.

Public Sub s_Gpe()
Dim sArr(), dArr(), tArr(), Tmp As Variant
Dim I As Long, J As Long, K As Long, K2 As Long, R As Long, Rws As Long
Dim Txt1 As String, Txt2 As String
    sArr = Sheets("Du lieu").Range("C2", Sheets("Du lieu").Range("C2").End(xlDown)).Resize(, 5).Value
    R = UBound(sArr)
ReDim tArr(1 To R, 1 To 2)
ReDim dArr(1 To R, 1 To 3)
With CreateObject("Scripting.Dictionary")
    For I = 1 To R
        Txt1 = sArr(I, 5)
        Txt2 = sArr(I, 1) & "#" & sArr(I, 5)
        If Not .Exists(Txt1) Then
            K = K + 1
            .Item(Txt1) = K
            tArr(K, 1) = sArr(I, 5)
            If Not .Exists(Txt2) Then
                .Item(Txt2) = ""
                tArr(K, 2) = I
            End If
        Else
            Rws = .Item(Txt1)
            If Not .Exists(Txt2) Then
                .Item(Txt2) = ""
                tArr(Rws, 2) = tArr(Rws, 2) & ";" & I
            End If
        End If
    Next I
End With
For I = 1 To K
    If InStr(tArr(I, 2), ";") Then
        Tmp = Split(tArr(I, 2), ";")
        For J = 0 To UBound(Tmp)
            K2 = K2 + 1
            dArr(K2, 1) = tArr(I, 1)
            dArr(K2, 2) = sArr(Tmp(J), 1)
            dArr(K2, 3) = sArr(Tmp(J), 2)
        Next J
        K2 = K2 + 1
    End If
Next I
Sheets("ketqua").Range("G3").Resize(R, 3).ClearContents
Sheets("ketqua").Range("G3").Resize(K2, 3) = dArr
End Sub

Code chạy đúng rồi ạ. Cảm ơn Anh nhiều ạ.