Sub recherche()
Dim cellule As Range
Range("G:H").ClearContents
For Each cellule In Range("B2:B" & Range("B65535").End(xlUp).Row)
derligne = Range("G65535").End(xlUp).Row + 1
If Left(cellule, 5) = "Merck" Then
Range("G" & derligne) = Cells(cellule.Row, 1)
Range("H" & derligne) = cellule
End If
Next cellule
End Sub