Segregating/displaying duplicates

Hi,

I have tried to modify the delete duplicate code to segregate/display code. the problem is, once a first loop is over it isn't returning as required.

inputs used
[TABLE="width: 64"]

[TD="width: 64"]aa[/TD]

mu

aa

gf

gh

ac

uy

ad

re

aa

mu

output: aa aa

[/TABLE]

Sub DelDups_OneList()
Dim iListCount As Integer
Dim iCtr As Integer
Dim te As Integer
Dim aa As Integer
Application.ScreenUpdating = False
iListCount = Sheets("Sheet1").Range("A1:A15").Rows.Count
te = 4
aa = 1
Sheets("Sheet1").Range("A1").Select
Do Until ActiveCell = ""
    For iCtr = 1 To iListCount
            If ActiveCell.Row <> Sheets("Sheet1").Cells(iCtr, 1).Row Then
       
         If ActiveCell.Value = Sheets("Sheet1").Cells(iCtr, 1).Value Then
            Sheets("Sheet1").Cells(iCtr, 1).Copy
            Sheets("Sheet1").Cells(1, te).Select
            ActiveSheet.Paste
            te = te + 1
        End If
      End If
   Next iCtr
   aa = aa + 1
   ActiveCell.Cells(aa, 1).Select
   Loop
Application.ScreenUpdating = True
End Sub

Thanks and regards,
prabhu.C

Re: Segregating/displaying duplicates

Thanks for your reply.
I have "x" values in a column among which "y" may be duplicates. i need to check for duplicates and display the duplicates in another column.
With above code first data is compared to all other data, but i need the loop so 2nd 3rd data etc also compared to entire column of data.
Hope I explained to you now.

Thanks and regards,
Prabhu.C

Re: Segregating/displaying duplicates

its working fine thanks a lot

Quote from apo;715359

Hi..

Try this..

It loops through Column A.. adding values into the Scripting Dictionary. When it comes across a Value that already exists in the Dictionary.. it puts it in Column B.
Finally.. it removes duplicates in Column B so that al that remains is 1 instance of each value that was a dupe..

Code

Private Sub CommandButton1_Click()
    Dim it, x0
    Application.ScreenUpdating = False
    With CreateObject("scripting.dictionary")
        For Each it In Sheets("Sheet1").Range("A2:A" & Sheets("Sheet1").Range("A" & Rows.Count).End(xlUp).Row)
            If .Exists(it.Value) Then
                Sheets("Sheet1").Range("B" & Sheets("Sheet1").Range("B" & Rows.Count).End(xlUp).Row).Offset(1).Value = it.Value
            Else
                x0 = .Item(it.Value)
            End If
        Next
    End With
    Sheets("Sheet1").Columns(2).RemoveDuplicates Columns:=1, Header:=xlNo
    Application.ScreenUpdating = True
End Sub

Display More

Display More