XL 2013 VBA - Mot(s) d'une cellule colorer selon liste

[DoubleZero]

Bonjour à toutes et à tous,

Grâce à un code de phlaurent55 , permettant de colorer en rouge un mot précis, j'ai réussi à "peinturlurer" différemment certains mots présents en colonne a de l'onglet "MFC".

Or, je ne parviens pas à :

- récupérer le code couleur de la police ;

- appliquer la taille souhaitée ;

- dupliquer la mise en forme (couleur, format et taille de police) depuis n'importe quel onglet ;

- insérer les codes "Font.Color" respectifs en colonne e de l'onglet "MFC".

S'il est compliqué (impossible) d’obtenir ce que je souhaite, peu importe.

Je vous un très Joyeux Noël et vous remercie pour votre aide.

A bientôt

 

[chris]

Bonjour et Joyeux Noël à tous

Si j'ai bien compris dans cette partie du code

         With ActiveCell.Characters(Start:=j, Length:=longueur).Font
                        .FontStyle = "Gras"
                        .Size = c.Font.Size ' OK
                        .Color = c.Font.Color
                        Cells(i, 5).Value = .Color
                    End With

 

[Dranreb]

Bonsoir, et Joyeux Noël.
Un essai :

Option Explicit
Option Compare Text

Sub test()
Colorer Feuil4.[D2:E14], Feuil4.[A2:A14]
Colorer Feuil1.[D2:E14], Feuil4.[A2:A14]
Colorer Feuil2.[A2:B14], Feuil4.[A2:A14]
End Sub

Sub Colorer(ByVal RngPhra As Range, ByVal RngMots As Range)
Dim TMots() As String, TCoul() As Long, TSize(), L&, Cel As Range, Z As String, P&
ReDim TMots(1 To RngMots.Rows.Count), TCoul(1 To UBound(TMots)), TSize(1 To UBound(TMots))
For L = 1 To UBound(TMots, 1)
   With RngMots(L, 1): TMots(L) = .Value: TCoul(L) = .Font.Color
      TSize(L) = .Font.Size: End With: Next L
For Each Cel In RngPhra.Columns(1).Cells
   Z = Cel.Value
   For L = 1 To UBound(TMots)
      P = InStr(Z, TMots(L))
      If P > 0 Then
         With Cel.Characters(Start:=P, Length:=Len(TMots(L))).Font
            .FontStyle = "Bold": .Color = TCoul(L)
            .Size = TSize(L): End With
         Cel.Offset(, 1).Value = TCoul(L): End If: Next L, Cel
End Sub

 

[DoubleZero]

Bonjour à toutes et à tous,

chris , Dranreb ,

Je vous remercie 1001 fois : vous m'avez offert un superbe cadeau de Noël !

A bientôt