Microsoft 365 différentes couleurs dans une cellule par vba

[fanfanm]

Bonjour,

Je voudrais avoir deux mots dans une cellule de couleurs différentes.
Grossièrement, le code ressemblerait à ça :

A = "voiture"
couleur(A)=rouge

B = "de sport"
couleur(B) = vert

cellule(A1)= A & " " & B

Est-ce que c'est possible?
Merci

 

[vgendron]

Bonjour

avec l'enregistreur de macro ca donne ca:

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "Voiture de sport"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "Voiture de sport"
    With ActiveCell.Characters(Start:=1, Length:=0).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=1, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16776961
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=9, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -11480942
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A7").Select
End Sub

à adapter selon tes besoins dans ton fichier

 

[fanfanm]

Bonjour

avec l'enregistreur de macro ca donne ca:

Sub Macro1()
'
' Macro1 Macro
'

'
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "Voiture de sport"
    Range("A6").Select
    ActiveCell.FormulaR1C1 = "Voiture de sport"
    With ActiveCell.Characters(Start:=1, Length:=0).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=1, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -16776961
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    With ActiveCell.Characters(Start:=9, Length:=8).Font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .Color = -11480942
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With
    Range("A7").Select
End Sub

à adapter selon tes besoins dans ton fichier

Ce n'est pas vraiment l'effet recherché car ce que vous venez de faire est de récupérer du texte dans une cellule. Hors ce que je veux, c'est de mettre un texte à partir du code vba. Et ce texte est composé de deux mots différents.

A est un mot de longueur variable récupéré dans la cellule A2 (par exemple). Tandis que B est un texte enregistrer sur vba.

Donc si je reprend mon premier exemple plus précisément :
A = cellule(A2)
couleur(A) = rouge

B= "de sport"
couleur(B) = vert

cellule(A1) = A & " " & B

Je ne sais pas si c'est plus clair comme ça

 

[vgendron]

non pas beaucoup plus clair
mais, je me suis amusé:
1) remplir les mots à concaténer (Colonne A et Colonne C)
2) sur la colonne B ou D, selectionner la couleur voulue en cliquant sur le bouton "choisir couleur"

puis une fois que les couleurs sont définies, cliquer sur le bouton "Colorer"

 

[patricktoulon]

Bonjour
je peux jouer moi aussi ???

Sub test1()
    Dim Mots, couleurs
    Mots = Array("voiture", "de sport")    'l'array des mots
    couleurs = Array(vbRed, vbGreen)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A4]    'appel de la fonction qui va faire le job
End Sub
'
Sub test2()
    Dim Mots, couleurs
    Mots = Array("toto", "titi", "riri", "fifi")    'l'array des mots
    couleurs = Array(vbRed, vbGreen, vbBlue, vbMagenta)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A5]    'appel de la fonction qui va faire le job
End Sub
'
Sub test3()
    Dim Mots, couleurs
    Mots = Array("ca fait", "mal", "a la", "tete", "ce jargon")    'l'array des mots
    couleurs = Array(vbRed, vbGreen, vbBlue, vbMagenta, vbYellow)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A6]    'appel de la fonction qui va faire le job
End Sub
'
'
Function PutWordColorOnCell(wordArray, colorArray, cel As Range)
    Dim I&, X&
    cel = Join(wordArray)
    For I = LBound(wordArray) To UBound(wordArray)
        X = InStr(1, cel.Value, wordArray(I), vbTextCompare)
        cel.Characters(X, Len(wordArray(I))).Font.Color = colorArray(I)
    Next
End Function

les couleurs peuvent être exprimées dans l'array de toute les manières que l'on puisse le faire
rgb
long
hexa

 

[patricktoulon]

allez une petite variante
on peut mettre
soit moins de couleurs que les mots( le reste de la valeur dans la cellule restera en noir)
soit le même nombre
si on veut du noir entre deux on met 0 dans l'item de l'array des couleurs
tout les exemples

Sub test1()
    Dim Mots, couleurs
    Mots = Array("voiture", "de sport")    'l'array des mots
    couleurs = Array(vbRed, vbGreen)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A4]    'appel de la fonction qui va faire le job
End Sub
'
Sub test2()
    Dim Mots, couleurs
    Mots = Array("toto", "titi", "riri", "fifi")    'l'array des mots
    couleurs = Array(vbRed, vbGreen, vbBlue, vbMagenta)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A5]    'appel de la fonction qui va faire le job
End Sub
'
Sub test3()
    Dim Mots, couleurs
    Mots = Array("ca fait", "mal", "a la", "tete", "ce jargon")    'l'array des mots
    couleurs = Array(vbRed, vbGreen, vbBlue, vbMagenta, vbYellow)    'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A6]    'appel de la fonction qui va faire le job
End Sub

Sub test4() '3 expressions et seulement les deux premieres couleurs
    Dim Mots, couleurs
    Mots = Array("moi j'aime pas ", "les couleurs", "ca pique les yeux")    'l'array des mots
    couleurs = Array(RGB(255, 100, 0), 1654236)   'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A7]    'appel de la fonction qui va faire le job
End Sub

Sub test5() ' couleur une sur deux
    Dim Mots, couleurs
    Mots = Array("moi j'aime pas ", "les couleurs", "ca pique les yeux", "noir c'est noir il n'y a plus d'espoir")   'l'array des mots
    couleurs = Array(RGB(255, 100, 0), 0, 16534836, 0) 'l'array des couleurs
    PutWordColorOnCell Mots, couleurs, Feuil1.[A8]    'appel de la fonction qui va faire le job
End Sub
'
'
Function PutWordColorOnCell(wordArray, colorArray, cel As Range)
    Dim I&, X&, C&
    cel = Join(wordArray)
    For I = LBound(wordArray) To UBound(wordArray)
        X = InStr(1, cel.Value, wordArray(I), vbTextCompare)
       If I > UBound(colorArray) Then C = vbBlack Else C = colorArray(I)
       cel.Characters(X, Len(wordArray(I))).Font.Color = C
    Next
End Function

 

[fanfanm]

Merci pour vos réponse je pense qu'avec ce qu'a fournis patricktoulon, je peux essayer de faire quelque chose qui correspond à ce que je veux faire.
Je vous tiendrai au courant.

 

[fanfanm]

Du coup en bidouillant un peu, j'ai réussi à faire ce que je voulais. Merci encore pour vos réponses.