XL 2010 Plusieurs écritures dans une même cellule ( Résolu )

[Kael_88]

Bonsoir le Forum,

Je me tourne vers vous pour un problème dont je ne trouve pas de solution correct si cela est possible,
je cherche dans une cellule lors de la validation par "entrer" que :
1- le texte soit copié sur deux lignes
2- sur la deuxième ligne, ajouter un "*" et une lettre, devant le texte copié et un "*" à la fin du texte
3- laisser la première ligne dans l’écriture et la taille ou elle se trouve, par contre, la deuxième ligne doit être en écriture "Monotype Corsiva" de taille "24".

Ps: le tout en VBA.

Merci à vous

Cordialement

 

[job75]

Bonjour Kael_88, Pierre, le forum,

J'ai revu votre macro Worksheet_Change, maintenant elle tient la route :

Private Sub Worksheet_Change(ByVal Target As Range)
Dim r As Range, tablo, i&, x$
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error Resume Next
If FilterMode Then ShowAllData 'si la feuille est filtrée

Set r = Intersect(Target, Range("A3:A" & Rows.Count), UsedRange)
For Each r In r 'si entrées multiples (copier-coller)
    If r <> "" And r(1, 6) = "" Then r(1, 6) = Now
    If r = "" And r(1, 6) <> "" Then r(1, 6) = ""
Next r

Set r = Intersect(Target, Range("D3:D" & Rows.Count), UsedRange)
For Each r In r.Areas 'si entrées multiples (copier-coller)
    tablo = r.Resize(, 2) 'matrice plus rapide, au moins 2 éléments
    For i = 1 To UBound(tablo)
        x = UCase(Replace(tablo(i, 1), " ", ""))
        If Left(x, 6) = "DEVIS" Then
            tablo(i, 1) = "DEVIS " & Mid(x, 7)
        ElseIf x <> "" Then
            tablo(i, 1) = Left(x, 1) & " " & Mid(x, 2)
        End If
    Next i
    r = tablo 'restitution
Next r

Application.EnableEvents = True
End Sub

Les couleurs en colonne F sont appliquées par MFC en fonction des heures qui s'y trouvent.

Fichier (3).

A+