Conditions pour un doublons dans la meme cellule [Résolu/Fermé]

Option Explicit
Sub XXX()
Const str As String = "88.1SX8"
Dim src As Range
Dim dst As Range
Dim cel As Range
Dim adr As String
  ' Plage des données source
  Set src = Worksheets(1).UsedRange
  ' Destination des lignes copiées
  Set dst = Worksheets(2).Cells.SpecialCells(xlCellTypeLastCell)
  If Not (dst.Address = "$A$1" And dst.Formula = "") Then
    ' Première cellule de destination libre
    Set dst = dst.EntireRow.Cells(1, 1).Offset(1)
  End If
  ' Chercher la première cellule contenant la valeur (str)
  Set cel = src.Find(str, , xlValues, xlPart)
  If Not cel Is Nothing Then
    ' mémoriser l'adresse de la première cellule (pour sortie de boucle)
    adr = cel.Address
    Do
      ' Verifier la présence d'un doublon ...
      If InStr(2, cel.Value, str) > 0 Then
        ' ... si présent copier la ligne
        cel.EntireRow.Copy Destination:=dst
        ' cellule de destination suivante
        Set dst = dst.Offset(1)
      End If
      ' Chercher la cellule suivante contenant la valeur
      Set cel = src.Find(str, cel, xlValues, xlPart)
      If cel Is Nothing Then Exit Do
      If cel.Address = adr Then Exit Do
    Loop
  End If
End Sub