PDA

View Full Version : Compare two worksheet current code modification



hakunamatata
10-16-2012, 11:29 AM
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
10-16-2012, 04:41 PM
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
10-17-2012, 09:42 AM
Thanks for your reply. Actually I need Vba code.

Teeroy
10-17-2012, 01:36 PM
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
10-17-2012, 09:14 PM
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:

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

hakunamatata
10-18-2012, 11:01 PM
Thanks a lot for your help. Today i will see it and then we discuss about it.

hakunamatata
10-19-2012, 07:19 AM
Hallo Again,
you code works very fine thanks for that. I also have modify some one others code attached with the workbook.