Try:
Sub CompareCols()
Application.ScreenUpdating = False
Dim Rng As Range, RngList As Object, WS As Worksheet, desWS As Worksheet, lastRow As Long
Set WS = ThisWorkbook.Sheets("Sheet2")
Set desWS = ThisWorkbook.Sheets("Sheet1")
Set RngList = CreateObject("Scripting.Dictionary")
For Each Rng In desWS.Range("B2", desWS.Range("B" & desWS.Rows.Count).End(xlUp))
If Not RngList.Exists(Rng.Value) Then
RngList.Add Rng.Value, Rng.Row
End If
Next
For Each Rng In WS.Range("B2", WS.Range("B" & WS.Rows.Count).End(xlUp))
If RngList.Exists(Rng.Value) Then
With desWS
WS.Range("O" & Rng.Row).Resize(, 5).Copy
.Cells(RngList(Rng.Value), 15).PasteSpecial xlPasteValues
End With
Else
lastRow = desWS.Range("B" & desWS.Rows.Count).End(xlUp).Row
WS.Rows(Rng.Row).EntireRow.Copy
desWS.Cells(lastRow + 1, 1).PasteSpecial xlPasteValues
End If
Next
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Bookmarks