hi.
sorry it took so long. I add text to columns. use if you want.
macro adds a sheet named results.
edit to fit your data.
Sub findstuff()
'Sheets("Sheet1").Select
'Range("A2:A4000").Select
'Selection.TextToColumns Destination:=Range("A2"),
DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False,
Tab:=True, _
Semicolon:=False, Comma:=True, Space:=False, Other:=False, FieldInfo _
:=Array(Array(1, 1), Array(2, 1), Array(3, 1), Array(4, 1), Array(5,
1), _
Array(6, 1),Array(7, 1), Array(8, 1)), TrailingMinusNumbers:=True
'Cells.AutoFit
Sheets.Add.Name = "Results"
Sheets("Sheet1").Select 'change if needed
Dim f As String
Dim ba As Range
Dim bb As Range
Dim bc As Range
Dim bd As Range
Dim r As Range
Set ba = Range("B2")
Set bc = Sheets("Results").Range("A2") 'destination 1
Application.CutCopyMode = False
ba.Copy
bc.PasteSpecial xlPasteAll
f = InputBox("Enter something to find.")
Do While Not IsEmpty(ba)
Set bb = ba.Offset(1, 0)
Set bd = bc.Offset(1, 0)
ba.Copy
bc.PasteSpecial xlPasteAll
On Error Resume Next
Set sr = Range(ba.Offset(0, -1), ba.Offset(0, -1).End(xlToRight))
sr.Select
If f <> "" Then
Set r = Nothing
Set r = sr.Find(What:=f, After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
End If
If r Is Nothing Then
Set bc = Nothing
Else
Application.CutCopyMode = False
r.Offset(0, 1).Copy
bc.Offset(0, 1).PasteSpecial xlPasteAll
End If
Set ba = bb
Set bc = bd
Loop
End Sub
test on your test data. works on xp2003
regards
FSt1
