Option Explicit
Sub ExtractListFromTable()
' constants
Const ksSourceWS = "Sheet1"
Const ksSourceRange = "SourceTable"
Const ksTargetWS = "Sheet2"
Const ksTargetRange = "TargetList"
Const ksArgument = "ArgumentCell"
' declarations
Dim rngS As Range, rngT As Range, c As Range
Dim vArgument As Variant
Dim I As Long, A As String
' start
Set rngS = Worksheets(ksSourceWS).Range(ksSourceRange)
Set rngT = Worksheets(ksTargetWS).Range(ksTargetRange)
vArgument = Worksheets(ksTargetWS).Range(ksArgument)
With rngT
If .Rows.Count > 1 Then Range(.Rows(2), .Rows(.Rows.Count)).ClearContents
End With
I = 1
' process
With rngS
Set c = .Find(vArgument, .Cells(1, 1), xlValues, xlPart, xlByColumns, , True)
Do Until c Is Nothing
' save 1st found
If A = "" Then A = c.Address
' add entry
I = I + 1
rngT.Cells(I, 1).Value = c.Value
' cycle
Set c = .FindNext(c)
' check if restarted
If A = c.Address Then Exit Do
Loop
End With
' end
Set rngT = Nothing
Set rngS = Nothing
Beep
End Sub
