XL 2010 Suppression texte surligné

[NICOALBERT]

Bonjour le Forum ,

J'ai une petite question concernant l'action sur une partie du texte dans une cellule .

Est il possible de supprimer le texte surligné dans une cellule sans supprimer tout le contenu ?

Cdlt Nicoalbert .

 

[pierrejean]

Bonjour NICOALBERT

Un essai

 

[NICOALBERT]

Bonjour Pierrejean ,

ça fonctionne à merveille un grand merci .

Par contre lorsque je met mes données la couleur de mon texte en bleu devient vert , a tu une idée de quoi ça me provenir ?

 

[pierrejean]

Re
je suppose que lorsque la macro modifie le texte (qui ne forme qu'une entité) la couleur de l’écriture vient à celle d'origine
Je regarde s'il est possible d'y remédier mais je suis assez sceptique !!!

 

[NICOALBERT]

Bonsoir le forum , pierrejean ,

Pierrejean as tu pu voir si il y avait moyen de garder les couleurs d'origine ?

cdlt Nicoalbert

 

[job75]

Bonjour NICOALBERT, Pierre,

Mieux vaut tard que jamais :

Private Sub CommandButton1_Click()
Dim c As Range, txt$, t$, coul$, i%, s
Application.ScreenUpdating = False
For Each c In [B3].CurrentRegion.Offset(1)
    txt = c: t = "": coul = ""
    For i = 1 To Len(c)
        If c.Characters(i, 1).Font.Underline = xlUnderlineStyleNone Then
            t = t & Mid(txt, i, 1)
            coul = coul & " " & c.Characters(i, 1).Font.Color 'mémorise la couleur
        End If
    Next i
    c = t 'nouveau texte
    s = Split(coul)
    For i = 1 To Len(c)
        c.Characters(i, 1).Font.Color = s(i) 'restitue la couleur
Next i, c
End Sub

Comme on peut le voir les couleurs sont mémorisées puis restituées.

Pour traiter la seule cellule B4 il faut chez moi 25 secondes !!!

A+

 

[job75]

Avec ce fichier (2) le traitement se fait en 18 secondes, on gagne donc 7 secondes (28%) :

Private Sub CommandButton1_Click()
Dim c As Range, txt$, t$, coul$, i%, s, n%
Application.ScreenUpdating = False
For Each c In [B3].CurrentRegion.Offset(1)
    txt = c: t = "": coul = ""
    For i = 1 To Len(c)
        If c.Characters(i, 1).Font.Underline = xlUnderlineStyleNone Then
            t = t & Mid(txt, i, 1)
            coul = coul & " " & c.Characters(i, 1).Font.Color 'mémorise la couleur
        End If
    Next i
    c = t 'nouveau texte
    coul = coul & " " 'un élément (vide) de plus pour s
    s = Split(coul)
    n = 1
    For i = 2 To UBound(s)
        If s(i) <> s(i - 1) Then
            c.Characters(n, i - n).Font.Color = s(n) 'restitue la couleur par paquet
            n = i
        End If
Next i, c
End Sub

 

[NICOALBERT]

Bonsoir Job75 , pierrejean , le Forum ,

Comme tu le dit si bien "me vaut tard que jamais" car je n'aurait jamais été capable de créer ce genre de macro .

Elle fonctionne à merveille .

Encore un très grand merci à vous 2 pour le temps que vous prenez pour nous aider .

Cdlt Nicoalbert .

 

[job75]

Dans la macro précédente j'ai ajouté un élément à s pour terminer correctement la dernière boucle i.

Bonne nuit.