Hi,
Try
Sub kTest()
Dim ka, k(), a, i As Long, c As Long, n As Long, dic As Object
'// user settings
Const strSourceData As String = "Before" 'Sheet Name
Const strNumsToKeep As String = "Numbers to Keep" 'Sheet Name
Const strDataColumns As String = "a:i"
Const strNumbersRange As String = "a1:a24"
Const lngNumColInData As Long = 1
Const strDestRange As String = "k1"
'// end of settings
With Worksheets(CStr(strSourceData))
ka = Intersect(.UsedRange, .Columns(CStr(strDataColumns)))
End With
With Worksheets(CStr(strNumsToKeep))
a = Intersect(.UsedRange, .Range(CStr(strNumbersRange)))
End With
Set dic = CreateObject("scripting.dictionary")
dic.comparemode = 1
For i = 1 To UBound(a, 1): dic.Item(CStr(a(i, 1))) = Empty: Next
ReDim k(1 To UBound(ka, 1), 1 To UBound(ka, 2))
For i = 1 To UBound(ka, 1)
If dic.exists(CStr(ka(i, lngNumColInData))) Then
n = n + 1
For c = 1 To UBound(ka, 2): k(n, c) = ka(i, c): Next
End If
Next
If n Then Worksheets(CStr(strSourceData)).Range(CStr(strDestRange)).Resize(n, UBound(ka, 2)).Value2 = k
End Sub
HTH
Bookmarks