Effacement de cellules

[JJ1]

Bonjour,

Je voudrais par une instruction VBA effacer toute cellule en A1 :Cx contenant une chaîne de caractères contenue dans la colonne Ix.
Les nombres sont tous au format texte (suite de la macro de Kendev et Job---Merci) ce qui corse la difficulté. (petit exemple joint).

Merci de votre aide.

Bon dimanche.

 

[mapomme]

Re : Effacement de cellules

Bonjour JJ1,

Un essai dans le fichier joint (pas vraiment optimisé!)

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

 

[JJ1]

Re : Effacement de cellules

Bonjour Ma pomme,

Merci pour ton code que je vais tester cet am.
Vu l'importance du nombre de lignes (autant en plage à effacer qu'en colonne I ), comment je peux modifier la plage d'effacement en A:B au lieu de A:C pour "accelérer" le processus d'effacement?
Merci à toi.

Bon am

 

[pierrejean]

Re : Effacement de cellules

Bonjour a tous

Ma version (valable pour colonnes A et B (n=1 to 2 pour A a C serait n=1 to 3))

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

 

[mapomme]

Re : Effacement de cellules

Bonjour JJ1,

Une adaptation qui ne traite qu'une colonne à la fois (l'utilisateur choisit la colonne A, B ou C).

Le bouton INIT sert à recopier le tableauINIT (M4:O32) dans les colonnes A à C pour réinitialiser les données (uniquement pour les tests de temps d'exécution et la mise au point).
Les temps sur mon bouzin (correspondent à INIT = 100)

 

[JJ1]

Re : Effacement de cellules

Bonjour Mapommme, Pierre-Jean, le Forum,
Merci pour ces différents codes qui vont me servir (et pas uniquement à moi, si j'en juge par les posts similaires (notamment l'effacement colonne a=colonne b en format texte de ce matin)
Je vais voir le temps d'exécution du code.
Merci et bonne journée à tous.