Compare two worksheet current code modification

[hakunamatata]

Hello Everybody,
The workbook attached with this thread, the code works fine. I just want to modify this code in such a way that it must compare if the same ID is written more than two times, the example is attached with the workbook.

[Teeroy]

Using "Tabelle2" sheet as an example use conditional formatting with the formula "=COUNTIF(C$5:C$12,C5)>1" in C5 to highlight duplicates. Copy the format to all cells in the range.

[hakunamatata]

Thanks for your reply. Actually I need Vba code.

[Teeroy]

I couldn't get your code to run (excel 2003) to do any testing (Automation error). It doesn't seem to like the "System.Collections.Sortedlist" object.
I'll try on excel 2010 at work later.

[Teeroy]

I'm not sure I've got all your requirements right but piecing together comments in the attachment and your posts I came up with you wanting to list multiple entries whether they are on Sheet1, Sheet2 or spread over both. The problem with the method that you've used is that the first time an entry is found it doesn't get listed as a multiple (subsequent ones do). It would be easier to collate the tables, check for multiples and copy them in using a temporary sheet. The following is quick and dirty and could probably use some optimisation but works:

[vba]Sub test3()
Dim temp As Worksheet
Dim rng As Range
Dim rng1 As Range
Dim lastrow As Long
Dim rngrow As Long
Application.DisplayAlerts = False
'add temp sheet to capture copies
ThisWorkbook.Sheets.Add After:=Sheets(Sheets.Count)
Set temp = Sheets(Sheets.Count)
' Copy Sheet1 to Temp sheet
Set rng1 = Sheets(1).Range("A3").CurrentRegion
Set rng = Sheets(1).Range(Sheets(1).Range("A3"), rng1.Cells(rng1.Rows.Count, rng1.Columns.Count))
rng.Copy temp.Range("A1")
' Copy Sheet2 to Temp sheet
Set rng1 = Sheets(2).Range("A12").CurrentRegion
Set rng = Sheets(2).Range(Sheets(2).Range("A12"), rng1.Cells(rng1.Rows.Count, rng1.Columns.Count))
rng.Copy temp.Range("a" & Rows.Count).End(xlUp).Offset(1, 0)
' Delete irrelevant columns
Union(temp.Columns("D"), temp.Columns("F")).Delete
'add COUNTIF helper column to find multiples
lastrow = temp.Range("A" & Rows.Count).End(xlUp).Row
Set rng1 = temp.Range("G2").Resize(lastrow - 1)
rng1.FormulaR1C1 = "=COUNTIF(r2c3:r" & lastrow & "c3,rc[-4])"
' Delete all rows that only have a single entry, leving multiples.
Set rng = rng1.Cells(1, 1)
Do
rngrow = rng.Row
If rng.Value < 2 Then
rng.EntireRow.Delete
rngrow = rngrow - 1
Set rng = temp.Cells(rngrow, 7)
End If
Set rng = rng.Offset(1, 0)
Loop While rng.Value <> ""
' copy list of multiples to Sheet3
temp.Range("A1").CurrentRegion.Resize(, 6).Copy Sheets(3).Range("a4")
'Delete Temp sheet
temp.Delete
Application.DisplayAlerts = True
End Sub[/vba]

[hakunamatata]

Thanks a lot for your help. Today i will see it and then we discuss about it.

[hakunamatata]

Hallo Again,
you code works very fine thanks for that. I also have modify some one others code attached with the workbook.