Effacement cellules

Bonsoir,

Voilà dans le tableau ci joint lorsque que la colonne B comporte des doublons (le même code plusieurs fois) le mot DOUBLON apparait dans la colonne A. Je souhaiterais que les colonnes B jusqu a J soient effacées pour les lignes en dessous de celle où il y a marqué DOUBLON et ayant biensur le même code. Dans l'exemple ci joint il faudrait que la ligne 7 reste inchangé mais que les cellules 8 à 11 des colonnes B à J soient effacées.

Voilà la macro de la partie concernée je n 'arrive à voir comment les effacer sans toucher à la ligne 7.

Merci de votre aide

Sub RechercheDoublon()
Dim i&, j%, Derlg&, DerlgWMS&, Lg&, Cpt%, Trouvé As Boolean, Mot() As Variant, WMS As Worksheet
Set WMS = Sheets("WMS")
Derlg = Range("B" & Rows.Count).End(xlUp).Row
DerlgWMS = WMS.Range("B" & Rows.Count).End(xlUp).Row
For i = 2 To Derlg
If Cells(i, 7) = "R" Or Cells(i, 7) = "r" Then Cells(i, 7) = "Rupture"
ActiveSheet.CmdDémarrer.Caption = "Recherche et mise en place doublons" & vbCrLf & vbCrLf & "Avancement " & 70 + Int((30 / DerlgWMS) * i) & " %" 'change le texte du bouton
Cpt = -1
Erase Mot
Trouvé = False
For j = 2 To DerlgWMS
If Cells(i, 2) = WMS.Cells(j, 2) Then
Cpt = Cpt + 1
ReDim Preserve Mot(DerlgWMS - 1, 7)
Mot(Cpt, 0) = WMS.Cells(j, 1)
Mot(Cpt, 1) = WMS.Cells(j, 2)
Mot(Cpt, 2) = WMS.Cells(j, 3)
Mot(Cpt, 3) = WMS.Cells(j, 4)
Mot(Cpt, 4) = WMS.Cells(j, 5)
Mot(Cpt, 5) = WMS.Cells(j, 6)
Mot(Cpt, 6) = WMS.Cells(j, 7)
If Cpt > 0 Then Trouvé = True
End If
Next j
If Trouvé = True Then
Cells(i, 1) = "DOUBLON"
Cells(i, 11) = ""
Cells(i, 12) = ""
For j = LBound(Mot) To UBound(Mot)
If Mot(j, 1) <> "" Then
Lg = Range("b" & Rows.Count).End(xlUp).Row + 1
Cells(Lg, 1) = Mot(j, 3)
Cells(Lg, 2) = Mot(j, 1)
Cells(Lg, 3) = Mot(j, 2)
Cells(Lg, 4) = Cells(i, 4)
Cells(Lg, 5) = Cells(i, 5)
Cells(Lg, 6) = Cells(i, 6)
Cells(Lg, 11) = Mot(j, 4)
Cells(Lg, 12) = Mot(j, 6)
Else
Exit For
End If
Next j
End If
Next i
Set WMS = Nothing
Tri
Bordure
End Sub