I got this to work.... I have four seperate macros and call each one from a
master macro. Appreciate the help Jim

Sub find1()
On Error GoTo ErrorHandler
Dim rngToSearch As Range
Dim wksData As Worksheet
Dim wksVLookup As Worksheet
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngFirst As Range
Dim rngDestination As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wksData = Sheets("Data")
Set wksVLookup = Sheets("VLookup")

Set rngDestination = wksVLookup.Cells(Rows.Count, _
"A").End(xlUp).Offset(1, 0)
Set rngToSearch = wksData.Range("j7:j712")
Set rngFound = rngToSearch.find(wksData.Range("d1").Value,
LookIn:=xlValues)
If rngFound Is Nothing Then
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound
Set rngAllFound = rngFound.Offset(0, -9)
Do
Range(rngAllFound, rngFound).Copy
rngDestination.PasteSpecial Paste:=xlPasteValues
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
End If
wksData.Select
wksData.Range("A6").Select

ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic

End Sub




"John" wrote:

oops forgot the code...

On Error GoTo ErrorHandler
Dim rngToSearch As Range
Dim wksData As Worksheet
Dim wksVLookup As Worksheet
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngFirst As Range
Dim rngDestination As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wksData = Sheets("Data")
Set wksVLookup = Sheets("VLookup")
Set rngDestination = wksVLookup.Cells(Rows.Count, _
"A").End(xlUp).Offset(1, 0)
Set rngToSearch = wksData.Range("j7:j712")
Set rngFound = rngToSearch.find(Sheets("data").Range("d1").Value,
LookIn:=xlValues)

If rngFound Is Nothing Then
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound
Set rngAllFound = rngFound.Offset(0, -9).Resize(rngFound.Rows.Count, _
rngFound.Columns.Count + 9)
Do
Set rngAllFound = Union(rngAllFound, rngFound.Offset(0, -9) _
.Resize(rngFound.Rows.Count, rngFound.Columns.Count + 9))
rngAllFound.Select
rngAllFound.Copy
rngDestination.PasteSpecial Paste:=xlPasteValues
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
End If
wksData.Select
wksData.Range("A6").Select

ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub




"Jim Thomlinson" wrote:

This should cover it...

Sub find()
Call colorprep(Sheets("data").Range("d1").Value)
Call colorprep(Sheets("data").Range("d2").Value)
Call colorprep(Sheets("data").Range("d3").Value)
Call colorprep(Sheets("data").Range("d4").Value)
End Sub

Sub colorprep(ByVal StringToFind As String)
On Error GoTo ErrorHandler
Dim rngToSearch As Range
Dim wksData As Worksheet
Dim wksLookup As Worksheet
Dim rngFound As Range
Dim rngAllFound As Range
Dim rngFirst As Range
Dim rngDestination As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wksData = Sheets("Data")
Set wksLookup = Sheets("Lookup")
Set rngDestination = wksLookup.Cells(Rows.Count, _
"A").End(xlUp).Offset(1, 0)
Set rngToSearch = wksData.Range("j7:j712")
Set rngFound = rngToSearch.find(StringToFind)

If rngFound Is Nothing Then
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound
Set rngAllFound = rngFound.Offset(0, -9).Resize(rngFound.Rows.Count, _
rngFound.Columns.Count + 9)
Do
Set rngAllFound = Union(rngAllFound, rngFound.Offset(0, -9) _
.Resize(rngFound.Rows.Count, rngFound.Columns.Count + 9))
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound.Address = rngFirst.Address
End If

'rngAllFound.EntireRow.Copy
rngAllFound.Select
rngAllFound.Copy
rngDestination.PasteSpecial Paste:=xlPasteValues

wksData.Select
wksData.Range("A6").Select

ErrorHandler:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub

--
HTH...

Jim Thomlinson


"John" wrote:

jim, that fixed the endless loop, but I am only getting one row pasted for
each macro (running it four times). Also, the time I run it with D1 value, I
am not getting the data pasted in correctly. Thanks alot for your help

here is the code I am using

Sub find()
Call colorprep(Sheets("data").Range("d1").Value)
Call colorprep(Sheets("data").Range("d2").Value)
Call colorprep(Sheets("data").Range("d3").Value)
Call colorprep(Sheets("data").Range("d4").Value)
End Sub
Sub colorprep(ByVal StringToFind As String)
Dim rngToSearch As Range
Dim wks As Worksheet
Dim rngFound As Range
Dim rngFirst As Range
'Dim WhatToFind As Variant
Dim DestCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wks = Sheets("DATA")
Set rngToSearch = wks.Range("j7:j712")

'WhatToFind = Array(Range("d1").Value, Range("d2").Value,
Range("d3").Value, Range("d4").Value)

Set rngFound = rngToSearch.find(StringToFind)
If rngFound Is Nothing Then
Range("a6").Select
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound
Do
saddr = rngFirst.Address
myRow = rngFirst.Row
'rngFound.EntireRow.Copy
'Destination:=DestCell
Range("a" & myRow, "j" & myRow).Select
Selection.Copy
Sheets("vlookup").Select
Range("a65536").End(xlUp).Offset(1, 0).Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound Is Nothing Or rngFound.Address = rngFirst.Address
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets("data").Select
Range("a6").Select
End Sub





"Jim Thomlinson" wrote:

Give this a whirl...

Dim rngToSearch As Range
Dim wks As Worksheet
Dim rngFound As Range
Dim rngFirst As Range
'Dim WhatToFind As Variant
Dim DestCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wks = Sheets("data")
Set rngToSearch = wks.Range("j7:j712") '***Changed

'WhatToFind = Array(Range("d1").Value, Range("d2").Value,
'Range("d3").Value, Range("d4").Value)

Set rngFound = rngToSearch.Find(what:=Sheets("data").Range("d1"). Value, _
LookIn:=xlValues, Lookat:=xlWhole)
If rngFound Is Nothing Then
Range("a6").Select
MsgBox "No new Floaters"
Else
Set rngFirst = rngFound '***Moved...
Do
'With Worksheets("vlookup")
'Set DestCell =
'Sheets("vlookup").Range("a65536").End(xlUp).Offse t(0, 1)
'End With

saddr = rngFound.Address
myrow = rngFound.Row
'rngFound.EntireRow.Copy
'Destination:=DestCell
Range("a" & myrow, "j" & myrow).Copy
Sheets("vlookup").Select
Range("a65536").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial xlValues
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound Is Nothing Or rngFound.Address = rngFirst.Address
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets("data").Select
Range("a6").Select
End Sub
--
HTH...

Jim Thomlinson


"John" wrote:

Jim thanks for the help. I am still having some issues.
It still seems to be in and endless loop (and I have taken out the array
just for testing). It also seems to copy cells that are to the right of my
rngToSearch column... as if it is moving over from that column rather than
starting on "d" or "a" or whatever column I select.

Here is the code now.
Dim rngToSearch As Range
Dim wks As Worksheet
Dim rngFound As Range
Dim rngFirst As Range
'Dim WhatToFind As Variant
Dim DestCell As Range

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

Set wks = Sheets("data")
Set rngToSearch = Sheets("data").Range("j7:j712")

'WhatToFind = Array(Range("d1").Value, Range("d2").Value,
Range("d3").Value, Range("d4").Value)

Set rngFound = rngToSearch.Find(what:=Sheets("data").Range("d1"). Value,
LookIn:=xlValues, Lookat:=xlWhole)
If rngFound Is Nothing Then
Range("a6").Select
MsgBox "No new Floaters"
Else
Do
'With Worksheets("vlookup")
'Set DestCell =
Sheets("vlookup").Range("a65536").End(xlUp).Offset (0, 1)
'End With
Set rngFirst = rngFound
saddr = rngFound.Address
myrow = rngFound.Row
'rngFound.EntireRow.Copy
'Destination:=DestCell
Range("a" & myrow, "j" & myrow).Copy
Sheets("vlookup").Select
Range("a65536").End(xlUp).Offset(1, 0).Select
ActiveCell.PasteSpecial xlValues
Set rngFound = rngToSearch.FindNext(rngFound)
Loop Until rngFound Is Nothing Or rngFound.Address = rngFirst.Address
End If
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Sheets("data").Select
Range("a6").Select
End Sub

"Jim Thomlinson" wrote:

There are at least four issues with your code...

1. You need to specify the sheet that the range you are searching is on.
2. You can not find an array. If you try it will only look for (first or
last I don't remember which) one of the items.
3. Find is an infinite loop. You want to stop when you get back to the firts
hit.
4. When you find nest you need to specify to start looking after the itme
you just found.

More like this...

Sub test()
Call findstuff("This")
Call findstuff("That")
End Sub