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

Xray · 5 Avril 2022

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 · 5 Avril 2022

Bien compris, alors utilisez cette macro :

VB:

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...

job75 · 5 Avril 2022

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 · 5 Avril 2022

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 · 5 Avril 2022

Bien compris, alors utilisez cette macro :

VB:

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 · 5 Avril 2022

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 · 6 Avril 2022

Bonjour Xray, le forum,

Bien noter qu'avec l'expression :

VB:

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 :

VB:

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 · 6 Avril 2022

job75 à dit:

Bien compris, alors utilisez cette macro :

VB:

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

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

Xray

XLDnaute Nouveau

job75

job75

XLDnaute Barbatruc

Xray

XLDnaute Nouveau

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

job75

XLDnaute Barbatruc

Xray

XLDnaute Nouveau

Discussions similaires