Hi Claus,

The ColumnsCompareOne code will copy down to the first non-match on sheet1 column C and then disregards any other marches further down the list.


The ColumnsCompareTwo code works well, where the non-matches are removed from the data while on sheet3.

Is it much trouble to make ColumnsCompareOne work for all matches on sheet1?
Having both codes would be nice, if not too much trouble.

Thanks.
Howard

Sub ColumnsCompareOne()
'/ Copies to the first non-match only

Dim i As Long, ii As Long

Dim LRow1 As Long, LRow2 As Long

Dim MyArr1 As Variant
Dim MyArr2 As Variant

Dim rngBig As Range

LRow1 = Sheets("Sheet1").Cells(Rows.Count, "C").End(xlUp).Row
MyArr1 = Sheets("Sheet1").Range("C2:C" & LRow1)
LRow2 = Sheets("Sheet2").Cells(Rows.Count, "H").End(xlUp).Row
MyArr2 = Sheets("Sheet2").Range("H2:H" & LRow2)

Application.ScreenUpdating = False

With Sheets("Sheet2")

For i = LBound(MyArr1) To UBound(MyArr1)
For ii = LBound(MyArr2) To UBound(MyArr2)
If MyArr1(i, 1) = MyArr2(ii, 1) Then


If rngBig Is Nothing Then

Set rngBig = .Range(.Cells(ii + 1, 1), .Cells(ii + 1, 26))
Else
Set rngBig = Union(rngBig, _
.Range(.Cells(ii + 1, 1), .Cells(ii + 1, 26)))
End If

End If
Next 'ii
Next 'i

End With


If Not rngBig Is Nothing Then

Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp)(2) _
.Resize(rngBig.Rows.Count, rngBig.Columns.Count) _
.Value = rngBig.Value

Else
MsgBox "no matches found"
End If

Application.ScreenUpdating = True
End Sub


Sub ColumnsCompareTwo()
'/ By Claus @ MSPublic
'/ Works fine

Dim i As Long, n As Long

Dim LRow As Long, LRow2 As Long
Dim MyArr As Variant


LRow2 = Sheets("Sheet2").Cells(Rows.Count, "H").End(xlUp).Row
MyArr = Sheets("Sheet2").Range("H2:H" & LRow2)

Application.ScreenUpdating = False

Sheets("Sheet2").Range("A2:Z" & LRow2).Copy

Sheets("Sheet3").Cells(Rows.Count, 1).End(xlUp)(2) _
.PasteSpecial xlPasteValues

With WorksheetFunction
LRow = Sheets("Sheet3").Cells(Rows.Count, "H").End(xlUp).Row

For i = LBound(MyArr) To UBound(MyArr)
If .CountIf(Sheets("Sheet1").Range("C:C"), MyArr(i, 1)) = 0 Then

n = .Match(MyArr(i, 1), Sheets("Sheet3").Range("H1:H" & LRow), 0)

Sheets("Sheet3").Rows(n).Delete
End If
Next
End With

End Sub