Deux couleurs de police dans une même cellule

bonjour,

sans macro je ne sais pas mais peut etre avec une macro (a adapter) du type

For k = 1 To Len(Range("A1").Value)
  Range("A1").Characters(k,1).Font.ColorIndex = k Mod 16
Next k

bonne suite

re

qui devrait répondre

Private Sub CommandButton1_Click() 
Const cellule = "A1" 
Const tiret = "-" 
Const nbrouge = 5 
Dim numtiret As Long 
Dim nbcar As Long 
Dim nucar As Long 
Dim c As String 
c = Range(cellule).Value 
nbcar = Len(c) 
numtiret = 0 
For nucar = 1 To nbcar 
  If Mid(c, nucar, 1) = tiret Then 
    nutiret = nutiret + 1 
    If nutiret <= nbrouge Then 
      Range(cellule).Characters(nucar, 1).Font.ColorIndex = 3 
    Else 
      Range(cellule).Characters(nucar, 1).Font.ColorIndex = 5 
    End If 
  End If 
Next nucar 
End Sub

en adaptant les valeurs des constantes bien sur

si tu as besoin de plus de détails n'hésites pa

bonne suite

re

la procedure était attachée a un bouton CommandButton_1 (pris dans la boite a outils controles)

on peut faire autrement avec une macro applicable a la cellule selectionnée à mettre dans un module et a déclencher par un Ctrl+f
(modifier eventuellement les codes couleurs et le type/nb de tirets rouges)

Sub Macro1() 
' 
' Touche de raccourci du clavier: Ctrl+f 
' 
Const tiret = "-" 
Const nbrouge = 5 
Dim nutiret As Long 
Dim nbcar As Long 
Dim nucar As Long 
Dim c As String 

c = Selection.Value 
nbcar = Len(c) 
nutiret = 0 
For nucar = 1 To nbcar 
  If Mid(c, nucar, 1) = tiret Then 
    nutiret = nutiret + 1 
    If nutiret <= nbrouge Then 
      Selection.Characters(nucar, 1).Font.ColorIndex = 3 
    Else 
      Selection.Characters(nucar, 1).Font.ColorIndex = 5 
    End If 
  End If 
Next nucar 

End Sub

bonne suite

re
remplacer const nbrouge = 5
par
dim nb rouge as long

puis avant for each ...

initialiser nbrouge avec par exemple la valeur de A1

nbrouge = Range("A1").Value

bonne suite

re

effectivement ce n'était pas prévu ...
RQ1. ceci concatene aussi bien mais ça ne résout pas ton problème
REPT("_";B2) & (REPT("_";H2)
RQ2. je n'ai pas trouvé de solution lorsque le résultat depend d'une formule
RQ3. Une solution (très mauvaise) consisterait a remplacer la formule par son resultat avant le traitement MAIS la formule est perdue et la cellule n'est plus du tout 'dynamique'

bonne suite quand même

re

je n'ai pas la solution a ton problème
il y a sur le forum des personnes beaucoup plus compétentes que moi > Vaucluse, Michel_m, eriic, m@rina, raymond pentier, etc ... qui pourront peut être t'aider
je suivrai le problème avec attention !!!
bonne suite

Bonjour,
Moi non plus je ne suis pas tellement compétant mais j'ai peut-être un début de solution.
Ne rien mettre dans la cellule K1
Dans le module de la feuille copier...

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
    If Target.Count > 1 Then Exit Sub
    If Target.Column = 2 And Target.Offset(, 6) > 0 Then
        Application.EnableEvents = False
        Target.Offset(, 9) = String(Target + Target.Offset(, 6), "_")
    With Target.Offset(, 9)
        With .Characters(Start:=1, Length:=Target).Font
            .ColorIndex = 5
        End With
        With .Characters(Start:=Target + 1, Length:=Len(Target.Offset(, 9))).Font
            .ColorIndex = 3
        End With
    End With
        Application.EnableEvents = True
        
    ElseIf Target.Column = 8 Then
        If Target.Offset(, -6) > 0 Then
            Application.EnableEvents = False
            Target.Offset(, 3) = String(Target + Target.Offset(, -6), "_")
            With Target.Offset(, 3)
                With .Characters(Start:=1, Length:=Target.Offset(, -6)).Font
                    .ColorIndex = 5
                End With
                With .Characters(Start:=Target.Offset(, -6) + 1, Length:=Len(Target.Offset(, -3))).Font
                    .ColorIndex = 3
                End With
                Application.EnableEvents = True
            End With
        End If
    End If
End Sub

Quand tu met une valeur dans Bx et Hx la cellule Kx se rempli comme tu veux, du moins c'est ce que je pense. :-(
A+

Maintenant, si tu a déjà beaucoup de lignes renseignées tu peu employé cette macro pour tout mettre à jour, et ensuite te servir du code ci-dessus

Private Sub ToutValider()
Dim Lig As Long
    Application.EnableEvents = False
    For Lig = 1 To Range("B65536").End(xlUp).Row
        If Cells(Lig, 2) > 0 And Cells(Lig, 8) > 0 Then
            Cells(Lig, 11) = String(Cells(Lig, 2) + Cells(Lig, 8), "_")
            With Cells(Lig, 11)
                With .Characters(Start:=1, Length:=Cells(Lig, 2)).Font
                    .ColorIndex = 5
                End With
                With .Characters(Start:=Cells(Lig, 2) + 1, Length:=Len(Cells(Lig, 11))).Font
                    .ColorIndex = 3
                End With
            End With
        End If
    Next Lig
    Application.EnableEvents = True
End Sub

A+

re,
je viens de voir l'idée de lermite222, a vue de nez, je ne sais pas si elle modifie les couleurs dans la cellule contenant la formule, c'est à tester bien sur

mes dernières idées
je reprends ma RQ3, MAIS je ne supprime plus la formule.
je te propose de faire une copie conforme de la feuille (FF) qui contient les formules dans une feuille (FR) qui ne contiendra que les résultats (valeurs) que l'on pourra traiter cette fois, et qui sera mise a jour automatiquement avec Worksheets_Change

constantes a modifier
RQ. la cellule qui contient le nombre de rouges voulu a été nommé nbrouge

Option Explicit

Const plage_utile = "A1:C10" 
Const tiret = "_"
Const derli = 10
Const derco = 3

Private Sub MAJFR()
Dim li As Long
Dim co As Long
  Application.EnableEvents = False
  For li = 1 To derli
    For co = 1 To derco
      Worksheets("FR").Cells(li, co).Value = Worksheets("FF").Cells(li, co).Value
    Next co
  Next li
  Application.EnableEvents = True
End Sub

Private Sub formate(plage As String)
Dim c As Range
Dim nbcar As Long
Dim nucar As Long
Dim nutiret As Long
Dim nbrouge As Long
nbrouge = Worksheets("FF").Range("nbrouge").Value
  For Each c In Worksheets("FR").Range(plage)
    nbcar = Len(c)
    nutiret = 0
    For nucar = 1 To nbcar
      If Mid(c, nucar, 1) = tiret Then
        nutiret = nutiret + 1
        If nutiret <= nbrouge Then
          c.Characters(nucar, 1).Font.ColorIndex = 3
        Else
          c.Characters(nucar, 1).Font.ColorIndex = 5
        End If
      End If
    Next nucar
  Next c
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
  Call MAJFR
  Call formate(plage_utile)
End Sub

le lien vers un exemple

http://www.cijoint.fr/cjlink.php?file=cj201011/cijxFA7yof.xls

bonne suite

Un classeur démo il contient une autre fonction que j'ai fait pour un autre poste, mais occupe-toi des fonctions 2couleurs.
Tu dis
L'expérience instruit plus sûrement que le conseil. (André Gide)
Si tu te cognes à un pot et que ça sonne creux, c'est pas forcément le pot qui est vide. ;-)(Confucius)

> lermite222
pas dans mes intentions de vexer qui que ce soit ....
à vue ... de machine cette fois, ta solution permet de détouner de façon très efficace le problème du coloriage (et le nombre de couleurs pour à peu près le même prix).
je me suis acharné à tenter le modifier la couleur au niveau de la cellule qui contient la formule (=REPT ....) et je n'y suis pas arrivé, d'ailleurs est-ce possible? En fait ta solution supprime le problème en supprimant la formule de la feuille et en donnant le boulot a VBA, c'est tout simplement lumineux!
je vais voir de ce pas le classeur que tu mets à disposition
cordialement