Want to separate unique and duplicate data from large data base

[sambha]

Hi i want to separate unique and duplicate data from my data base. But it must be check two different condition and then separate the data .
e.g. if i have customer data where i have customer name, address, pincode. here macro can check customer name first and if macro find same name then macro check his address also if both name and address is same then only he can cut data and past to other sheet.
please find attached sheet for your reference.

[jindon]

try

Sub test()
    Dim a, i As Long, ii As Long, txt As String
    Dim n As Long, e, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Cells(1).CurrentRegion
        a = .Value
        .ClearContents
        For i = 1 To UBound(a, 1)
            txt = Join(Array(a(i, 2), a(i, 3)), Chr(2))
            If Not dic.exists(txt) Then
                n = n + 1: dic(txt) = Empty
                For ii = 1 To UBound(a, 2)
                    a(n, ii) = a(i, ii)
                Next
            Else
                dic(txt) = Application.Index(a, i, 0)
            End If
        Next
        For Each e In dic.keys
            If Not IsArray(dic(e)) Then dic.Remove e
        Next
        .Resize(n).Value = a
        With .Offset(, .Columns.Count + 1)
            If dic.Count Then
                .Resize(dic.Count).Value = Application.Index(dic.items, 0, 0)
            End If
        End With
    End With
End Sub

[MarvinP]

Hi sambha and welcome the forum,

See the attached with two helper columns. See if this gets you closer to your answer.

[sambha]

Thanks a lot,
this work .......
but i want to shift duplicate data on new sheet.
please help me on this issue

thanks in advance...

[jindon]

If you are talking to me
change

        With .Offset(, .Columns.Count + 1)

to

        With Sheets("Sheet2").Cells(1).Resize(, UBound(a,2))

[sambha]

Hi Jindon,
please find attached file i have data in that format and want to separate duplicate on new sheet i was tried the changes which you suggest.
i used command button for that. please use attached sheet and help me to create unique data

[jindon]

Col.L,M & N makes address

Sub test()
    Dim a, i As Long, ii As Long, txt As String
    Dim n As Long, e, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Cells(1).CurrentRegion
        a = .Value
        .ClearContents
        For i = 1 To UBound(a, 1)
            txt = Join(Array(a(i, 4), a(i, 12), a(i, 13), a(i, 14)), Chr(2))
            If Not dic.exists(txt) Then
                n = n + 1: dic(txt) = Empty
                For ii = 1 To UBound(a, 2)
                    a(n, ii) = a(i, ii)
                Next
            Else
                dic(txt) = Application.Index(a, i, 0)
            End If
        Next
        For Each e In dic.keys
            If Not IsArray(dic(e)) Then dic.Remove e
        Next
        .Resize(n).Value = a
        With Sheets.Add.Cells(1).Resize(, .Columns.Count + 1)
            If dic.Count Then
                .Resize(dic.Count).Value = Application.Index(dic.items, 0, 0)
            End If
        End With
    End With
End Sub

[BS Singh]

Hi Jindon,

Could you please add comments for my understanding?

Regards,

[jindon]

Sub test()
    Dim a, i As Long, ii As Long, txt As String
    Dim n As Long, e, dic As Object
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    With Cells(1).CurrentRegion
        ' store data in an array to speed up the process
        a = .Value
        .ClearContents
        For i = 1 To UBound(a, 1)
            ' unique key (name/Col. D & Address(Col. L, M & N)
            ' joined by Chr(2) which is merely used in the real world for the safety.
            txt = Join(Array(a(i, 4), a(i, 12), a(i, 13), a(i, 14)), Chr(2))
            If Not dic.exists(txt) Then
                ' if unique, increase the counter "n", add txt to the dictionary with empty value
                n = n + 1: dic(txt) = Empty
                ' substitute the row value to "n"th row in array "a"
                For ii = 1 To UBound(a, 2)
                    a(n, ii) = a(i, ii)
                Next
            Else
                ' If not unique, change its item to the array of that row.
                ' this is for the deleted row for the dups.
                dic(txt) = Application.Index(a, i, 0)
            End If
        Next
        ' loop through the dictionary
        For Each e In dic.keys
            ' If item is not an array then remove it from the dictionary
            ' so that, if some remains, it will be dups to be reported.
            If Not IsArray(dic(e)) Then dic.Remove e
        Next
        ' dump the data from the array
        .Resize(n).Value = a
        With Sheets.Add.Cells(1).Resize(, .Columns.Count + 1)
            ' if any item remains in dictionary
            If dic.Count Then
                ' dump the items to the range
                .Resize(dic.Count).Value = Application.Index(dic.items, 0, 0)
            End If
        End With
    End With
End Sub

[BS Singh]

Thanks Jindon. Would you mind telling me the best link to learn Dictionary object..

You deserve Rep+..

Regards,

[sambha]

Thanks Jindon,
thanks a lot for your help,i want your little more help regarding this macro.
i create one button for this macro and i put this code for this button and work also but now i want to do some changes in it .i want to make it more user friendly , macro will ask user to input column no. or on which field user want(field can 1 or more) to find duplication
please find attached file for your reference

[sambha]

in short we have to create one small form for it . or tell me other solution for it

[jindon]

in short we have to create one small form for it . or tell me other solution for it

It's your choice.
If you go with userform, prepare it and attach it to your file.

[jindon]

And tell me the reason for having blank column in Col.I.

It is a very poor data structure to have blank Rows/Columns within a data range.

[sambha]

Dear Jindon,
i delete that column to make file size small . original file size is upto 11BM

[jindon]

That doesn't answer to my question.

Anyway w/o userform

[sambha]

Thanks Jindon.
you truly deserve respect .
thanks a lot...

[jindon]

If this solved your problem, you should mark the thread as "Solved".

[sambha]

thank everyone and specially Jindon,
my problem is solve now...

[sambha]

Hi Jindon
when i try this on other data it remove just few duplicates not all,
i already checked all spelling ,any extra space or char have included in it but nothing like that. and also when i used your old macro it work and give me all duplicates

[jindon]

No idea about what you are talking about.

[sambha]

Dear Jindon,
Macro is not accepting user input. Macro still work on the column (name, add1,add2,add3).
please check red text.

Sub test()
Dim a, i As Long, ii As Long, txt As String
Dim n As Long, e, dic As Object, rng As Range, r As Range
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
On Error Resume Next
Set rng = Application.InputBox("Select header(s)" & vbLf & _
"If multiple cells, holding down Ctl key and select", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
With Sheets("sheet1")
With .Range("a1", .Cells.SpecialCells(11))
a = .Value
.ClearContents
For i = 1 To UBound(a, 1)
For Each r In rng
txt = txt & Chr(2) & a(i, r.Column)
Next
txt = Join(Array(a(i, 4), a(i, 12), a(i, 13), a(i, 14)), Chr(2))
If Not dic.exists(txt) Then
n = n + 1: dic(txt) = Empty
For ii = 1 To UBound(a, 2)
a(n, ii) = a(i, ii)
Next
Else
dic(txt) = Application.Index(a, i, 0)
End If
txt = ""
Next
For Each e In dic.keys
If Not IsArray(dic(e)) Then dic.Remove e
Next
.Resize(n).Value = a
With Sheets.Add.Cells(1).Resize(, .Columns.Count + 1)
If dic.Count Then
.Resize(dic.Count).Value = Application.Index(dic.items, 0, 0)
End If
End With
End With
End With
End Sub

[jindon]

Your post does not comply with Rule 3 of our Forum RULES. Use code tags around code.

Posting code between [CODE] [/CODE] tags makes your code much easier to read and copy for testing, it also maintains VBA formatting.

Highlight your code and click the # icon at the top of your post window. More information about these and other tags can be found here



(This thread should receive no further responses until this moderation request is fulfilled, as per Forum Rule 7)

[sambha]

Dear Jindon,
Macro is not accepting user input. Macro still work on the column (name, add1,add2,add3).i.e. 4,12,13,14 column
please check red text.

Sub test()
Dim a, i As Long, ii As Long, txt As String
Dim n As Long, e, dic As Object, rng As Range, r As Range
Set dic = CreateObject("Scripting.Dictionary")
dic.CompareMode = 1
On Error Resume Next
Set rng = Application.InputBox("Select header(s)" & vbLf & _
"If multiple cells, holding down Ctl key and select", Type:=8)
On Error GoTo 0
If rng Is Nothing Then Exit Sub
With Sheets("sheet1")
With .Range("a1", .Cells.SpecialCells(11))
a = .Value
.ClearContents
For i = 1 To UBound(a, 1)
For Each r In rng
txt = txt & Chr(2) & a(i, r.Column)
Next
txt = Join(Array(a(i, 4), a(i, 12), a(i, 13), a(i, 14)), Chr(2))
If Not dic.exists(txt) Then
n = n + 1: dic(txt) = Empty
For ii = 1 To UBound(a, 2)
a(n, ii) = a(i, ii)
Next
Else
dic(txt) = Application.Index(a, i, 0)
End If
txt = ""
Next
For Each e In dic.keys
If Not IsArray(dic(e)) Then dic.Remove e
Next
.Resize(n).Value = a
With Sheets.Add.Cells(1).Resize(, .Columns.Count + 1)
If dic.Count Then
.Resize(dic.Count).Value = Application.Index(dic.items, 0, 0)
End If
End With
End With
End With
End Sub

[sambha]

Dear Jindon ,
Please help me .......

[jindon]

I can not help you unless I see your actual file.

It is not the code, but your data layouts I guess.

[sambha]

hi jindon,
please find attached my actual data file...
please help me to sort data by accepting user input(user choice column)

[jindon]

Which column(s) did you select as a unique key?

[sambha]

Hi Jindon,
unique key is depend on user. User must have rights to choose column(s) as unique key. Mostly name , address and mobile number we are considering as the unique key, but column selection and combination is depends on user.

[jindon]

Then I must say it is working as I programmed, end of the story.

[sambha]

Hi Jindon,
If code is working as per user choice input then why you use below code ?
and if i use column 4 (name )as user input it must show me 28 duplicates but it shows only 3 duplicate instead of 28. please use my last data file which i sent you. please use macro on it and see the result you will get every time only 3 duplication.

 txt = Join(Array(a(i, 4), a(i, 12), a(i, 13), a(i, 20)), Chr(2))

please check data file i highlighted duplicates in yellow color.

[jindon]

Just delete that line.

That is the line I missed to delete, due to your request has been changing.

[sambha]

Thanks Jindon,
it working great, only last thing i want to add
please find below example .

i.e. Mr. ABC have 4 entry in data if i use macro it shows 1 entry in unique data and 1 entry in duplication(3 entry must be seen in duplicates)
thats why i m not able to match my unique and duplicate data.

please help me on this last point

[jindon]

Sub test()
    Dim a, i As Long, ii As Long, txt As String, x As Range
    Dim n As Long, e, dic As Object, rng As Range, r As Range
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    On Error Resume Next
    Set rng = Application.InputBox("Select header(s)" & vbLf & _
                "If multiple cells, holding down Ctl key and select", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    With Sheets("sheet1")
        With .Range("a1", .Cells.SpecialCells(11))
            a = .Value
            .ClearContents
            For i = 1 To UBound(a, 1)
                For Each r In rng
                    txt = txt & Chr(2) & a(i, r.Column)
                Next
                If Not dic.exists(txt) Then
                    n = n + 1: dic(txt) = Empty
                    For ii = 1 To UBound(a, 2)
                        a(n, ii) = a(i, ii)
                    Next
                Else
                    If x Is Nothing Then
                        Set x = Union(.Rows(1), .Rows(i))
                    Else
                        Set x = Union(x, .Rows(i))
                    End If
                End If
                txt = ""
            Next
            .Resize(n).Value = a
        End With
    End With
    If Not x Is Nothing Then
        With Sheets.Add
            x.Copy .Cells(1)
            x.EntireRow.Delete
        End With
    End If
End Sub

[sambha]

hii jindon,
macro works but macro remove all duplicate data and paste to new sheet .
macro must be left 1st record in unique data and shift other in new sheet.
e.g abc have 4 entry then 1 must be in unique and other 3 in new sheet where is duplicate data is transferred. macro move all 4 entry to new sheet

[jindon]

Sub test()
    Dim a, i As Long, txt As String, x As Range
    Dim dic As Object, rng As Range, r As Range
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    On Error Resume Next
    Set rng = Application.InputBox("Select header(s)" & vbLf & _
                "If multiple cells, holding down Ctl key and select", Type:=8)
    On Error GoTo 0
    If rng Is Nothing Then Exit Sub
    With Sheets("sheet1")
        With .Range("a1", .Cells.SpecialCells(11))
            a = .Value
            For i = 1 To UBound(a, 1)
                For Each r In rng
                    txt = txt & Chr(2) & a(i, r.Column)
                Next
                If Not dic.exists(txt) Then
                    dic(txt) = Empty
                Else
                    If x Is Nothing Then
                        Set x = Union(.Rows(1), .Rows(i))
                    Else
                        Set x = Union(x, .Rows(i))
                    End If
                End If
                txt = ""
            Next
            If Not x Is Nothing Then
                With Sheets.Add
                    x.Copy .Cells(1)
                    x.EntireRow.Delete
                End With
            End If
        End With
    End With
End Sub

[sambha]

Hi Jindon,
yu are too good and very kind and respected person..
can ihave your Mail Id, I want to connect with you to learn more about macro....
please share your mail id or facebook id

[sambha]

My problem has solve ........
But column header is also moved to new sheet.
My column header must remain in main sheet also paste to new sheet. Is it possible ?

[jindon]

You should mark the thread as "Solved".

[jindon]

                Else
                    If x Is Nothing Then
                        Set x = Union(.Rows(1), .Rows(i))
                    Else
                        Set x = Union(x, .Rows(i))
                    End If
                End If
                txt = ""
            Next
            If Not x Is Nothing Then
                With Sheets.Add
                    x.Copy .Cells(1)
                    x.EntireRow.Delete
                End With
            End If
        End With

↓

                Else
                    If x Is Nothing Then
                        Set x = .Rows(i)
                    Else
                        Set x = Union(x, .Rows(i))
                    End If
                End If
                txt = ""
            Next
            If Not x Is Nothing Then
                Union(.Rows(1), x).Copy Sheets.Add.Cells(1)
                x.EntireRow.Delete
            End If
        End With

To mark the thread as "SOLVED", select Thread Tools from the menu link above and mark this thread as SOLVED.