Originally Posted by Ben McClave

Jerry,

Try this instead. There are two procedures below. The key component is a Function from Ozgrid.com that will return a range with all cells matching a find value. The first procedure calls that function and (assuming that the range returned is not Nothing), will copy the entire row for each found item and paste them to a new workbook.

Let me know if this one gives you any trouble.

Ben

Sub MoveToNewWB()
Dim ws As Worksheet 'ICD Sheet
Dim wbNew As Workbook 'New WB
Dim wsDest As Worksheet 'Destination WS
Dim rFind As Range 'Range to search for names
Dim rFound As Range 'Range of found names
Dim sFind As String 'Name to find

'Assign variables
Set ws = ThisWorkbook.Sheets("ICD")
Set rFind = ws.Range("A1:A100")
sFind = ThisWorkbook.Sheets("HOME").Range("A1").Value

'Find names
On Error Resume Next
Set rFound = Find_Range(sFind, rFind).EntireRow

'Copy name rows over to new book
If Not rFound Is Nothing Then
Workbooks.Add
Set wbNew = ActiveWorkbook
Set wsDest = wbNew.Sheets(1)
ws.Range("1:1").Copy wsDest.Range("1:1") 'Copy headers
rFound.Copy
wsDest.Range("A2").PasteSpecial (xlPasteAll)
Application.CutCopyMode = False
Else
MsgBox sFind & " not found."
End If

End Sub
Function Find_Range(Find_Item As Variant, _
Search_Range As Range, _
Optional LookIn As Variant, _
Optional LookAt As Variant, _
Optional MatchCase As Boolean) As Range

'http://www.ozgrid.com/forum/showthread.php?t=27240

Dim c As Range
Dim firstAddress As String
If IsMissing(LookIn) Then LookIn = xlValues 'xlFormulas
If IsMissing(LookAt) Then LookAt = xlWhole 'xlPart
If IsMissing(MatchCase) Then MatchCase = False

With Search_Range
Set c = .Find( _
What:=Find_Item, _
LookIn:=LookIn, _
LookAt:=LookAt, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=MatchCase, _
SearchFormat:=False)
If Not c Is Nothing Then
Set Find_Range = c
firstAddress = c.Address
Do
Set Find_Range = Union(Find_Range, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If
End With

End Function