Microsoft 365 supprimer seulement les doublons consécutives dans la même cellule

[Xray]

Bonjour à tous,

Je suis débutant avec VBA - EXCEL, J'aurais besoin de vote aide SVP.
J'ai un tableau Excel de plusieurs colonnes, les cellules de la colonne N° 24 contiennent des valeurs déferlantes

La ligne suivante est un exemple de valeur d'une cellule :
*AA1234* T18057J *AA1234* M25857H *CT9853* CRG057H *AA1234* C98052G M18052F *NT3578* A1G052F TR8052E ZA8052D *QI364D* *LOCAL* RTI44C C880G1B *HHJIOP* C78051A LOCAL* H180CCB *HHJIOP* B25857H *MOP81R* L18R03B B18IP3A *LOCAL CRG057H C98052G *AA1234* TB85G2E

Résultat ex souhaitait dans une cellule :
*AA1234* *CT9853* *AA1234* *NT3578* *QI364D* *HHJIOP* *MOP81R* *AA1234*

Le résultat de mon code (il supprime toutes les valeurs en double):
*AA1234* *CT9853* *NT3578* *QI364D* *HHJIOP* *MOP81R*

Mon objectif est de conserver uniquement toutes les valeurs entre deux étoiles et de supprimer tout le reste y compris : *LOCAL* ou *LOCAL ou LOCAL* et y compris la deuxième valeur en double consécutive entre deux étoiles comme *AA1234* et *HHJIOP* (doublons consécutifs)


En vous remerciant par avance

voici le code que j'ai pu développer:

Public Sub SplitCarte2()

Dim Ligne, Colonne, TestLoc, LigneMax As Integer
Dim Onglet, Carte2, ItiLocaux As String
Dim Tstring() As String

Onglet = ActiveSheet.Name

Ligne = 3
Colonne = 24
LigneMax = Range("X" & Rows.Count).End(xlUp).Row + 1

Do While Ligne <= LigneMax

ItiLocaux = ""
Carte2 = Sheets(Onglet).Cells(Ligne, Colonne).Value

Tstring() = Split(Carte2)

For Each Elem In Tstring()

TestLoc = InStr(1, Elem, "*")
If TestLoc = 1 And Elem <> "*LOCAL*" Then
If TestLoc = 1 And Elem <> "LOCAL*" Then
If TestLoc = 1 And Elem <> "*LOCAL" Then
If InStr(1, ItiLocaux, Elem, 1) = 0 Then
ItiLocaux = ItiLocaux & Elem
End If
End If
End If
End If

Next

Sheets(Onglet).Cells(Ligne, Colonne).Value = ItiLocaux
Ligne = Ligne + 1
Loop

End Sub

 

[job75]

Bonjour Xray, bienvenue sur XLD,

Avec l'exemple que vous donnez on ne comprend pas du tout la logique des suppressions.

Pourquoi T18057J ou M25857H etc doivent-ils disparaître ?

A+

 

[Xray]

Salut Job75,

En fait, je souhaiterais conserver les valeurs avec deux étoiles. (une au début de la valeur et une à la fin de la valeur)

Exemple de valeurs souhait conserver *AA1234* et pas T18057J ou M25857H, car elles ne contiennent pas d'étoiles
En même temps je souhaiterais supprimer seulement les trois valeurs suivante *LOCAL* , LOCAL* ou *LOCAL

Merci

 

[job75]

Bien compris, alors utilisez cette macro :

Sub Epurer()
Dim tablo, i&, s, j%, x$
With Range("X3", Range("X" & Rows.Count).End(xlUp))
    tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To UBound(tablo)
        s = Split(tablo(i, 1))
        For j = 0 To UBound(s)
            x = s(j)
            If Left(x, 1) <> "*" Or Right(x, 1) <> "*" Or InStr(x, "LOCAL") Then s(j) = ""
        Next j
        x = Application.Trim(Join(s)) 'concaténation + SUPPRESPACE
        s = Split(x)
        For j = UBound(s) To 1 Step -1
            If s(j) = s(j - 1) Then s(j) = ""
        Next j
        tablo(i, 1) = Application.Trim(Join(s)) 'concaténation + SUPPRESPACE
    Next i
    .Value = tablo 'restitution
End With
End Sub

Si vous ne connaissez pas Split et Join recherchez sur le web.

 

[job75]

Pour tester j'ai copié la ligne de l'exemple dans 50 000 cellules en colonne X.

Chez moi la macro s'exécute en 1,7 seconde.

 

[job75]

Bonjour Xray, le forum,

Bien noter qu'avec l'expression :

If Left(x, 1) <> "*" Or Right(x, 1) <> "*" Or InStr(x, "LOCAL") Then s(j) = ""

un mot comme "DELOCALISE* sera supprimé car il contient LOCAL.

Si on veut le conserver utiliser :

If Left(x, 1) <> "*" Or Right(x, 1) <> "*" Or x = "*LOCAL*" Then s(j) = ""

LOCAL seul ou encadré par 1 ou 2 astérisques sera supprimé.

A+

 

[Xray]

Bien compris, alors utilisez cette macro :

Sub Epurer()
Dim tablo, i&, s, j%, x$
With Range("X3", Range("X" & Rows.Count).End(xlUp))
    tablo = .Resize(, 2) 'matrice, plus rapide, au moins 2 éléments
    For i = 1 To UBound(tablo)
        s = Split(tablo(i, 1))
        For j = 0 To UBound(s)
            x = s(j)
            If Left(x, 1) <> "*" Or Right(x, 1) <> "*" Or InStr(x, "LOCAL") Then s(j) = ""
        Next j
        x = Application.Trim(Join(s)) 'concaténation + SUPPRESPACE
        s = Split(x)
        For j = UBound(s) To 1 Step -1
            If s(j) = s(j - 1) Then s(j) = ""
        Next j
        tablo(i, 1) = Application.Trim(Join(s)) 'concaténation + SUPPRESPACE
    Next i
    .Value = tablo 'restitution
End With
End Sub

Si vous ne connaissez pas Split et Join recherchez sur le web.

Le code a été testé avec succès.
Je vous remercie pour votre aide