Removing and finding the Duplicates from arrays or excel sheet Rows entries

[mandukes]

I need to remove duplicates from rows in excel sheet and also find the no of duplicates found in the current row.

1	2	5	1	3
6	5	4	6	5
6	9	5	4	9

<tbody>
</tbody>

Output:

1 2 5 3
6 5 4
6 9 5 4

Can it be achieved using an arrays.

Dim ArrItem(100,50) as Integer 
ArrItems(1) = ArrItems(1,2,5,1,3)
ArrItems(2) = ArrItems(6,5,4,6,5)
ArrItems(3) = ArrItems(6,9,5,4,9)

Thanks and regards
~M

 

[Peter_SSs]

.. and also find the no of duplicates found in the current row.

1. Where do you want recorded the number of duplicates found in each row?

2. How do you count duplicates? That is, in the sample below, does this row have 2 duplicates (1 and 2) or does it have 3 duplicates (1, 2 and 1)?

Book1
	A	B	C	D	E	F	G
2	1	2	1	3	2	1	4
Dupes

3. Do all rows have the same number of values to start with (5 in your example)?

 

[mandukes]

1. Where do you want recorded the number of duplicates found in each row?

Before Each row.

For example:
If 3 dupes found in the following.

	Dupes	B	C	D	E	F	G
2		1	3	2	1	2	1

<tbody>
</tbody>

The dupe should be removed from the Row i.e. 1,2,1
Giving the output as:

Output:

	Dupes	B	C	D	E	F	G
2	3	1	3	2

<tbody>
</tbody>

2. How do you count duplicates? That is, in the sample below, does this row have 2 duplicates (1 and 2) or does it have 3 duplicates (1, 2 and 1)?

	A	B	C	D	E	F	G
2	1	2	1	3	2	1	4

<tbody>
</tbody>

In your example given above.
It has 3 duplicates (1, 2 and 1)

​

3. Do all rows have the same number of values to start with (5 in your example)?

No, it can have more than 5 upto 100


Thanks

 

[Fluff]

Hi
Wasn't sure if you wanted to overwrite your data or copy the info to a new sheet.
This will write the unique values & the number of duplicates to a sheet called new.
You'll need to change the sheet name in red to match your data sheet.

Sub Del_DupesInRw()
' mandukes

    Dim Cl As Range
    Dim Rw As Long
    Dim Dupes As Long
    
Application.ScreenUpdating = False

    On Error Resume Next
    Sheets.Add.Name = "New"
    If Err.Number Then ActiveSheet.Delete
    On Error GoTo 0
    
    Sheets("[COLOR=#ff0000]overall[/COLOR]").Activate
    With CreateObject("scripting.dictionary")
        For Rw = 1 To Range("A" & Rows.Count).End(xlUp).Row
            For Each Cl In Range("A" & Rw, Cells(Rw, Columns.Count).End(xlToLeft))
                If Not .exists(Cl.Value) Then
                    .Add Cl.Value, Nothing
                Else
                    Dupes = Dupes + 1
                End If
            Next Cl
            Sheets("New").Rows(Rw).ClearContents
            Sheets("New").Range("A" & Rw) = Dupes
            Sheets("New").Range("B" & Rw).Resize(, .Count) = .keys
            Dupes = 0
            .removeall
        Next Rw
    End With
    
End Sub

 

[mandukes]

Thanks for the reply,
the code worked , The problem has been solved, I want to close this thread but couldn't find the option to do so..

 

[Peter_SSs]

I want to close this thread but couldn't find the option to do so..

We don't have such an option in this forum because even though an OP (you) may be satisfied with one of the responses, it is not uncommon for somebody to come along later and offer an even better solution that you, or other readers, may want to use instead.

 

[Fluff]

Thanks for the reply,
the code worked , The problem has been solved, I want to close this thread but couldn't find the option to do so..

Glad to help &thanks for the feedback