Compare 2 sheet and paste the resault on sheet3

[parscon]

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


sheet2


sheet3

[Ray.Mason]

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/libr.../ff835873.aspx


Thanks,

Ray

[parscon]

Dear Ray , Thank you but your VBA does not work . Thank you again .

[Imaginative1]

Instead of pasting to the Active Sheet, you might want to try pasting to the selected cell.

[parscon]

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]

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]

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