ok forget the previous mail. I have made some modification as you can see below. and now it works thanks for everything mate.


Happy new year by the way! ;)
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
'Dim dd As DropDown 'DropDown box
'Set dd = ThisWorkbook.Sheets("Home").Shapes("Combo Box1").OLEFormat.Object
'sFind = dd.List(dd.ListIndex)


Dim strVar As String

With Worksheets("Home")
strVar = .DropDowns("Zone combinée 89").List _
(.DropDowns("Zone combinée 89").ListIndex)
End With

MsgBox strVar

sFind = strVar

'Assign variables

Set ws = ThisWorkbook.Sheets("ICD")
Set rFind = ws.Range("D2:D100")
sFind = strVar



'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
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