[VBA]
Sub aaa()
Dim FoundCell, rCell As Range
Dim d, strFirstAddress As String

With Sheet1.Columns(2)
Set rCell = .Find(2, lookat:=xlWhole, LookIn:=xlValues)
strFirstAddress = rCell.Address
Set FoundCell = rCell
Do
d = d & rCell.Offset(, -1) & ";"
Set rCell = .FindNext(rCell)
Set FoundCell = Union(FoundCell, rCell)
Loop While Not rCell Is Nothing And rCell.Address <> strFirstAddress

MsgBox Left(d, Len(d) - 1)
End With
End Sub

[/VBA]