CODEWITHSUNDEEP
excelvba
hikari sakunami
hikari sakunami

Reputation: 35

Compare 2 columns between different worksheets then paste values

I have 2 worksheets (S1 & S2). I need a macro in S1 that will copy all the visible rows to S2 if the values of Columns B & C of every rows in S1 is not yet existing or equal to any row values in Worksheet S2 Columns D & E.

Worksheet S1:

Worksheet S1

Worksheet S2:

enter image description here

Expected Result in S2 when the Button is Clicked:

enter image description here

This is what I have so far:

Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Sheets("S1").Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim rng As Range
Dim foundVal As Range
For Each rng In Sheets("S1").Range("A2:A" & LastRow)
    Set foundVal = Sheets("S2").Range("A:A").Find(rng, LookIn:=xlValues, lookat:=xlWhole)
    If foundVal Is Nothing Then
    
    If rng.EntireRow.Hidden = False Then
            rng.EntireRow.Copy
            Sheets("S2").Cells(Rows.Count, "A").End(xlUp).Offset(1, 0).PasteSpecial xlPasteValues
    End If
            
            
    End If
Next rng
Application.CutCopyMode = False
Application.ScreenUpdating = True

Upvotes: 1

Views: 93

Answers (2)

VBasic2008
VBasic2008

Reputation: 54777

Copy Missing Data Using RemoveDuplicates

Option Explicit

Sub copyMissing()
    
    ' Constants
    Const sName As String = "S1"
    Const dName As String = "S2"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim strg As Range: Set strg = wb.Worksheets(sName).Range("A1").CurrentRegion
    Dim srg As Range: Set srg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    
    ' Destination
    Dim dtrg As Range: Set dtrg = wb.Worksheets(dName).Range("A1").CurrentRegion
    Dim dCell As Range: Set dCell = dtrg.Cells(1).Offset(dtrg.Rows.Count)
    Dim drg As Range: Set drg = dCell.Resize(srg.Rows.Count, srg.Columns.Count)
    Set dtrg = dtrg.Resize(dtrg.Rows.Count + srg.Rows.Count)
    
    ' Copy and Remove Duplicates
    Application.ScreenUpdating = False
    drg.Value = srg.Value
    dtrg.RemoveDuplicates Array(1, 2, 3), xlYes
    Application.ScreenUpdating = True
    
End Sub

EDIT

Sub copyMissing2()
    
    ' Constants
    Const sName As String = "S1"
    Const dName As String = "S2"
    
    ' Workbook
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Source
    Dim strg As Range: Set strg = wb.Worksheets(sName).Range("A1").CurrentRegion
    Dim srg As Range: Set srg = strg.Resize(strg.Rows.Count - 1).Offset(1)
    
    ' Destination
    Dim dtrg As Range: Set dtrg = wb.Worksheets(dName).Range("A1").CurrentRegion
    Dim dCell As Range: Set dCell = dtrg.Cells(1).Offset(dtrg.Rows.Count)
    
    Application.ScreenUpdating = False
    
    ' Copy
    Dim drg As Range: Set drg = dCell.Resize(srg.Rows.Count)
    drg.Value = srg.Columns(1).Value
    Set drg = drg.Offset(, 3).Resize(, 2)
    drg.Value = srg.Columns(2).Resize(, 2).Value
    
    ' Remove Duplicates
    Set dtrg = dtrg.Resize(dtrg.Rows.Count + srg.Rows.Count)
    dtrg.RemoveDuplicates Array(1, 4, 5), xlYes
    
    Application.ScreenUpdating = True
    
End Sub

Upvotes: 1

FunThomas
FunThomas

Reputation: 29146

I assume that in your sheet S2 you have only unique data before the copy. In that case it is probably much easier to first copy all data (except the header row) from sheet S1 to S2 and then use the remove duplicates function.

Sub copyUnique()
    Dim LastRowSource As Long, LastRowDest As Long
    Dim wsSource As Worksheet, wsDest As Worksheet
    
    Set wsSource = ThisWorkbook.Sheets("S1")
    Set wsDest = ThisWorkbook.Sheets("S2")
    
    LastRowSource = wsSource.Cells(wsSource.Rows.Count, "A").End(xlUp).row
    LastRowDest = wsDest.Cells(wsDest.Rows.Count, "A").End(xlUp).row
    
     wsSource.Range("A2:C" & LastRowSource).Copy wsDest.Range("A" & LastRowDest + 1)
    ' Remove the duplicates
    With wsDest.Range("A2:C" & (LastRowDest + LastRowSource - 1))
        .RemoveDuplicates Columns:=Array(1, 2, 3), Header:=xlYes
    End With
End Sub

Upvotes: 0

Related Questions