PDA

View Full Version : [SOLVED] Check sheet1 Copy duplicate items rows on sheet2 to sheet3



parscon
02-19-2014, 05:17 AM
I have two sheets , sheet1 and sheet2 , in sheet1 i have some data on column A and in sheet 2 also i have some data ,

Now i need a VBA code that check the column A on sheet1 and if find the duplicate on column A on sheet2 copy all the rows of duplicated item on sheet2 to sheet 3 .

The important thing copy all the duplicated rows in sheet2 to sheet3 .

Sample :

http://i58.tinypic.com/10ojtdc.png

Thank you

patel
02-19-2014, 06:33 AM
Sub a()
Set sh1 = Sheets(1)
Set rng2 = Sheets(2).UsedRange
Set sh3 = Sheets(3)
drow = 1
LR = sh1.Cells(Rows.Count, "A").End(xlUp).Row
For r = 1 To LR
nam = sh1.Cells(r, 1)
If Application.WorksheetFunction.CountIf(rng2.Resize(, 1), nam) > 1 Then
For rr = 1 To rng2.Rows.Count
If rng2(rr, 1) = nam Then
sh3.Cells(drow, 1) = rng2(rr, 1)
sh3.Cells(drow, 2) = rng2(rr, 2)
drow = drow + 1
End If
Next
End If
Next

End Sub

parscon
02-19-2014, 07:00 AM
Thank you very much but it will copy only column A and B i need copy the row .

Thank you again

p45cal
02-19-2014, 09:35 AM
This can be done with 1, perhaps 2 lines:
Sub Macro2()
Sheets("Sheet3").Cells.Clear
Sheets("Sheet2").Columns("A:B").AdvancedFilter Action:=xlFilterCopy, CriteriaRange:=Sheets("Sheet1").Range("A1:A2"), CopyToRange:=Sheets("Sheet3").Range("A1"), Unique:=False
End Sub
but...
Sheet2 needs to have unique headers in row 1 in as many columns as you want to copy across.
Sheet1 needs the single header in A1 exactly the same as column A header in sheet2, as well as the value sought in A2
The code line starting:

Sheets("Sheet2").Columns("A:B").AdvancedFilter…
needs adjusting to cover the columns you want to copy over, so if 5 columns, you need to change it to:
Sheets("Sheet2").Columns("A:E").AdvancedFilter…
and again, all columns must have a header.

parscon
02-19-2014, 09:41 AM
Thank you very much p45cal