PDA

View Full Version : Compare 2 sheet and paste the resault on sheet3



parscon
01-02-2014, 05:11 PM
I have 3 sheets , sheet1-sheet2-sheet3(is empty)

I have some data on sheet1 and also i have some data on sheet2, now , i need a VBA to check all column on the row each row that have data with sheet2 and if find any duplicate data on each column of each row copy the row from sheet1 and the row of sheet2 to sheet3 (both of them)
and delete the duplicate row from sheet2.

if you see the below picture in sheet1 on row A1 i have some data that A1 is 101 and if you check the sheet2 on C3 the same data that mean 101 and it will copy both of them to sheet3 that mean all the row . and delete the row on sheet2 .
just it will not check only column A it will check all column of sheet1 and sheet2 and if find any duplicate on each column that are same will copy the rows on sheet3.

Hope you will understand . Really i need this VBA code please help me .

Also i attached the same example on excel file .

Thank you very much .

sheet1
http://i42.tinypic.com/103h10j.png

sheet2
http://i41.tinypic.com/2vujwqq.png

sheet3
http://i40.tinypic.com/254xxmc.png

Ray.Mason
01-03-2014, 10:01 AM
Hi Parscon,

Not too sure I understood correctly and I'm also not much of an expert.


Sub comparesheets()Dim i As Integer
lastrow = Cells(Rows.Count).End(xlUp).Row
For i = 1 To lastrow
If Cells(i, 1).Value = Cells(i, 2).Value Then
Cells(i, 1).Rows("1:1").EntireRow.Select
Selection.Copy
Sheets("Sheet3").Activate
Sheets("Sheet3").Select
Range("A1").Select
ActiveSheet.Paste
Exit For
End If
Next i
End Sub

The above compares what's within same sheet then copies to sheet3. I think you will need to modify this to compare all cell individual values in sheet1 and do a find (can record a macro for this) and if there's a match then copy entire row to sheet3 (also another loop here, i.e. copy first instance in row A1, next A2 etc.

Also please try this link http://msdn.microsoft.com/en-us/library/office/ff835873.aspx


Thanks,

Ray

parscon
01-03-2014, 02:25 PM
Dear Ray , Thank you but your VBA does not work . Thank you again .

Imaginative1
01-03-2014, 02:33 PM
Instead of pasting to the Active Sheet, you might want to try pasting to the selected cell.

parscon
01-03-2014, 02:59 PM
The problem is i have in sheet 1 and sheet 2 about 875000 Row and the duplicate data are not in specify column , for example one row have 23 column . so how can find and select them ?

Thank you

parscon
01-03-2014, 03:47 PM
i found this VBA code but this VBA code will be delete the duplicate in sheet2 , i need copy the duplicate from sheet1 and sheet2 to sheet3



Sub DelDups_TwoLists()
Dim iListCount As Integer
Dim iCtr As Integer

' Turn off screen updating to speed up macro.
Application.ScreenUpdating = False

' Get count of records to search through (list that will be deleted).
iListCount = Sheets("sheet2").Cells(Rows.Count, "A").End(xlUp).Row

' Loop through the "master" list.
For Each x In Sheets("Sheet1").Range("A1:T" & Sheets("Sheet1").Cells(Rows.Count, "A").End(xlUp).Row)
' Loop through all records in the second list.
For iCtr = iListCount To 1 Step -1
' Do comparison of next record.
' To specify a different column, change 1 to the column number.
If x.Value = Sheets("Sheet2").Cells(iCtr, 1).Value Then
' If match is true then delete row.
Sheets("Sheet2").Cells(iCtr, 1).EntireRow.Delete
End If
Next iCtr
Next
Application.ScreenUpdating = True
MsgBox "Done!"
End Sub

mancubus
01-19-2014, 01:05 AM
hi parscon.

if the procedure you pasted works for deleting the duplicates, just add a line to copy the row to Sheet3 before deleting it.

that procedure will look for cell values in Sheet1 in Column A of Sheet2. i think you need to compare all cells in Sheet1 to all cells in Sheet2.


try this. take into account that it may take too much time to complete the procedure.




Sub DelDups_TwoLists()

Dim calc As Long, foundRow As Long
Dim rng1 As Range, rng2 As Range, cll As Range

With Application
.ScreenUpdating = False
.DisplayAlerts = False
.EnableEvents = False
calc = .Calculation
.Calculation = xlCalculationManual
End With

Set rng1 = Sheets("Sheet1").UsedRange
Set rng2 = Sheets("Sheet2").UsedRange

For Each cll In rng1
If Len(cll.Value) > 0 Then 'skip blank cells
If Application.CountIf(rng2, cll.Value) > 0 Then 'cell value exists in Sheet2
foundRow = rng2.Find(cll.Value).Row
Sheets("Sheet2").Rows(foundRow).EntireRow.Copy Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp).Offset(1)
Sheets("Sheet2").Rows(foundRow).EntireRow.Delete
End If
End If
Next

With Application
.EnableEvents = True
.Calculation = calc
End With


End Sub