Sub FindDupesAndCopy()
Dim sh1 As Worksheet, sh2 As Worksheet, sh3 As Worksheet
Dim Rws1 As Long, Rng1 As Range, a As Range
Dim Rws2 As Long, rng2 As Range, c As Range
Dim NextRow As Long
' Set worksheets
Set sh1 = Sheets("Sheet1")
Set sh2 = Sheets("Sheet2")
Set sh3 = Sheets("Sheet3")
' Define ranges for Sheet1 and Sheet2
Rws1 = sh1.Cells(sh1.Rows.Count, "A").End(xlUp).Row
Set Rng1 = sh1.Range("A4,A18") ' Explicitly selecting A4 and A18
Rws2 = sh2.Cells(sh2.Rows.Count, "A").End(xlUp).Row
Set rng2 = sh2.Range("A1:A" & Rws2)
' Identify the first empty row in Sheet3, Column A
NextRow = sh3.Cells(sh3.Rows.Count, "A").End(xlUp).Row + 1
' Loop through selected cells in Sheet1
For Each a In Rng1.Cells
' Check for a match in Sheet2, Column A
For Each c In rng2.Cells
If a.Value = c.Value Then
' Copy the matching value to the first empty row in Sheet3
sh3.Cells(NextRow, 1).Value = a.Value
NextRow = NextRow + 1 ' Move to next empty row
Exit For ' Exit inner loop once a match is found
End If
Next c
Next a
End Sub