Find duplicates in colA in one sheet and write them in another sheet with row reference

Hi

I have a problem that im not able to solve. In col A in sheet 1 i have some data, number of rows will vary. If the data occurs more then one time i want to be informed about it in another sheet. I want to know which rows that are "infected" and the value in col A. Like this:


sheet 1
A
1 490
2 390
3 700
4 700
5 700
6 600

Then in sheet 2:

Rows Value
3 700
4 700
5 700

Hope someone can help me!

/Masun

One way

Sub test()
    Dim x
    With Sheets("sheet1").Range("a1").CurrentRegion.Columns(1)
        x = Filter(.Parent.Evaluate("transpose(if(countif(" & .Address & "," & .Address & _
        ")=1,char(2),row(" & .Address & ")&char(1)&" & .Address & "))"), Chr(2), 0)
    End With
    With Sheets("sheet2").Range("a1").Resize(UBound(x) + 1)
        .CurrentRegion.ClearContents
        If UBound(x) > -1 Then
            .Value = Application.Transpose(x)
            .TextToColumns Destination:=Range("A1"), OtherChar:=Chr(1)
        End If
    End With
End Sub

Trebor76, jindon!

Thank you very much, it works great. Is there a way to separate the answer so that the row information will be put in one column and the value in a column next to it instead of getting the answer in one cell with both the row number and the value that is duplicated? Lets say it starts in E5 with the row number and in D5 the value. If that is possible it sure would be perfect!!

/Masun

jindon,

Of course I did. It resulted with 1 in cell A1. In cell A2 the first information came wit first the row number (in my case 66) with some space to the value. (In my case 81642799). The next duplicate came in A3. (in my case row 434) It looked like this:
1
64 81642799
434 81642799

/Masun

Yeah, see my previous post. (edited)

jindon,

I was writing mine while you edited yours. Its close to perfection now. ;-) I just wonder if there is a way to avoid to have the "1" above the answers? And now a new question popped up, what if there are no duplicates, what happens then?

/Masun

"1" ?
Can you post your file? Coz I can not replicate this.

How do you want when No dups find?
Currently it clears the destination and that's all.

jindon,

If there are no duplicates a msgbox with that info would be nice, otherwise this is great if you just could avoid the "1" above the answers. See attached file.

Thank you very much for your effort!

/Masun

OK, you have blank row on the top.

Sub Duplicates()
    Dim x
    With Sheets("GrundData")
        With .Range("a2", .Range("a" & Rows.Count).End(xlUp))
            x = Filter(.Parent.Evaluate("transpose(if(countif(" & .Address & "," & .Address & _
            ")=1,char(2)," & .Address & "&char(1)&row(" & .Address & ")))"), Chr(2), 0)
        End With
    End With
    With Sheets("Dublettkontroll").Range("d5").Resize(UBound(x) + 1)
        .CurrentRegion.ClearContents
        If UBound(x) > -1 Then
            .Value = Application.Transpose(x)
            .TextToColumns Destination:=.Cells(1), _
            Other:=True, OtherChar:=Chr(1)
        Else
            MsgBox "No duplicates"
        End If
    End With
End Sub

jindo,

Perfect!! Thank you very much!!

/Masun

jindo,

It seems i cheered a little bit to early, sorry for that...If I run the macro it finds the duplicates and place them correctly in the other sheet. But if i then remove the rows containing the duplicates and run the macro again it stops on this:

With Sheets("Dublettkontroll").Range("d5").Resize(UBound(x) + 1)

Could you please help me once again?

/Masun

Again, I can not replicate....


How did you remove the duplicates?

Hi,

Sorry for not making any sense. After i run the macro the first time, which works, i know where the duplicates are (on which rows in sheet GrundData). After that i remove/delete the duplicates in sheet GrundData manually. Then i run the macro a second time, just for a test, and it is stoped. Have uploaded a new file with no duplicates in.

Thanks so much for your effort in helping me!

OOps, sorry.
It should be like this.

Sub Duplicates()
    Dim x
    With Sheets("GrundData")
        With .Range("a2", .Range("a" & Rows.Count).End(xlUp))
            x = Filter(.Parent.Evaluate("transpose(if(countif(" & .Address & "," & .Address & _
            ")=1,char(2)," & .Address & "&char(1)&row(" & .Address & ")))"), Chr(2), 0)
        End With
    End With
    With Sheets("Dublettkontroll").Range("d5")
        .CurrentRegion.ClearContents
        If UBound(x) > -1 Then
            With .Resize(UBound(x) + 1)
                .Value = Application.Transpose(x)
                .TextToColumns Destination:=.Cells(1), _
                Other:=True, OtherChar:=Chr(1)
            End With
        Else
            MsgBox "No duplicates"
        End If
    End With
End Sub

jindo,

Thank you very, very much! Perfect!!!

/Masun