Effacement de cellules

Sub EffacerACselonI()
Dim Vali, xRgi As Range, Maxi, Aux
Dim xCell As Range, i, j, k, S, egal As Boolean
Dim Vala, xRga As Range, N

With Sheets("Feuil1")
    Set xRgi = .Cells(.Rows.Count, "I").End(xlUp)
    Set xRgi = Range(.Cells(1, "I"), xRgi)
    ' calcul du nombre max de nbre dans une ligne
    For Each xCell In xRgi
        If UBound(Split(xCell, ";")) + 1 > Maxi Then Maxi = UBound(Split(xCell, ";")) + 1
    Next xCell
    ReDim Vali(1 To xRgi.Rows.Count, 1 To Maxi + 1)
    ' remplissage du tableau
    For i = 1 To xRgi.Rows.Count
        Aux = Split(Cells(i, "I"), ";")
        Vali(i, 1) = UBound(Aux) + 1
        For j = LBound(Aux) To UBound(Aux)
            Vali(i, j + 2) = Aux(j)
        Next j
    Next i

    Set xRga = .Cells(.Rows.Count, "A").End(xlUp)
    Set xRga = Range(.Cells(1, "A"), xRga)
    Set xCell = .Cells(.Rows.Count, "B").End(xlUp)
    Set xCell = Range(.Cells(1, "B"), xCell)
    Set xRga = Union(xRga, xCell)
    Set xCell = .Cells(.Rows.Count, "C").End(xlUp)
    Set xCell = Range(.Cells(1, "C"), xCell)
    Set xRga = Union(xRga, xCell)
    
    For Each xCell In xRga
        S = ";" & xCell & ";"
        For i = 1 To UBound(Vali, 1)
            egal = True
            For j = 1 To Vali(i, 1)
                If InStr(S, ";" & Vali(i, j + 1) & ";") = 0 Then
                    egal = False
                    Exit For
                End If
            Next j
            If egal Then xCell.ClearContents
        Next i
    Next xCell
End With

End Sub

Function est_dans(est, dans)
xx = Split(dans, ";")
yy = Split(est, ";")
For n = LBound(yy) To UBound(yy)
  For m = LBound(xx) To UBound(xx)
    If yy(n) = xx(m) Then tot = tot + 1
  Next m
Next n
If tot = UBound(yy) + 1 Then est_dans = True
End Function
Sub test()
For n = 1 To 2
 For nn = Cells(65536, n).End(xlUp).Row To 1 Step -1
  For m = 1 To Range("I65536").End(xlUp).Row
   If Cells(nn, n) <> "" And est_dans(Range("I" & m), Cells(nn, n)) Then
      Cells(nn, n).Delete Shift:=xlShiftUp
      Exit For
   End If
  Next m
 Next nn
Next
End Sub