Discussion :

[lmc71]

Bonjour le forum
Je viens de découvrir ce code permettant de mettre en couleur et en taille un chiffre se trouvant dans une phrase sise dans une cellule.

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
Private Sub Worksheet_Change(ByVal Target As Range)
Dim c1 As Range, c2 As Range, c3 As Range
Set c1 = [A1]: Set c2 = [A2]: Set c3 = [A3]
If Intersect(Target, Union(c1, c2)) Is Nothing Then Exit Sub
c3 = c2
If c1 = "" Then Exit Sub
With c3.Characters(InStr(c3, c1), Len(c1)).Font
  .ColorIndex = 3 'rouge
  .Bold = True 'gras
  .Size = 20
End With
 
End Sub

ce code fonctionne lorsque l'on change manuellement la valeur de la A1
Ce que je souhaiterais est que le code fonctionne quand la valeur A1 change suite à un calcul.
D'après 78Chris il semblerait qu'il n'est pas possible depuis le résultat d'une formule. C'est mon cas d'où mon interrogation.
Est ce que cela est possible ?
Cordialement

[anasecu]

Bonjour,

Ce que je souhaiterais est que le code fonctionne quand la valeur A1 change suite à un calcul.

Tu peux essayer avec cette macro sur calcul :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Private Sub Worksheet_Calculate()
Dim c1 As Range, c2 As Range, c3 As Range
Set c1 = [A1]: Set c2 = [A2]: Set c3 = [A3]
c3 = c2
If c1 = "" Then Exit Sub
With c3.Characters(InStr(c3, c1), Len(c1)).Font
  .ColorIndex = 3 'rouge
  .Bold = True 'gras
  .Size = 20
End With
End Sub

[lmc71]

Re Anasecu
Merci de ta réponse rapide.
J'ai essayé sur un nouveau fichier et l'effet escompté n'a pas apparu.
Peut-être que je m'y suis mal pris.
Je te joins ce bout de fichier avec explications.
Cordialement

[Transitoire]

Bonjour,

Ce que je souhaiterais est que le code fonctionne quand la valeur A1 change suite à un calcul.

D'ou ma question, quel est l'évenement qui déclenche le calcul qui va modifier la valeur de A1? Car je pense que c'est aussi par la que l'on peut avoir un accès à la modification ou au calcul.
Cordialement

[anasecu]

Bonjour lmc71,

J'ai essayé sur un nouveau fichier et l'effet escompté n'a pas apparu.Peut-être que je m'y suis mal pris.

Tu as mal positionné ta fin de procédure, regardes comme ceci et cela va fonctionner

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
Private Sub Worksheet_Calculate()
Dim c1 As Range, c2 As Range, c3 As Range
Set c1 = [F1]: Set c2 = [A2]: Set c3 = [B4]
c3 = c2
If c1 = "" Then Exit Sub
With c3.Characters(InStr(c3, c1), Len(c1)).Font
  .ColorIndex = 3 'rouge
  .Bold = True 'gras
  .Size = 20
End With
End Sub

[lmc71]

Bonjour Anasecu
merci
Excuses moi pour cette erreur grossière que je n'arrivais pas à voir.
Tout fonctionne et je l'ai transporté sur mon fichier définitif et euréka ça fonctionne.
Je voudrais te demander si dans la phrase où il existe deux chiffres, est-ce qu'il est possible de les mettre les deux en forme.
Ces deux chiffres proviennent de deux formules différentes et se trouvent dans deux cellules différentes.
Voici les genre de phrase : Liste des 24 pays dans 6 groupes. Ce sont 24 et 6 à mettre en forme. Pour 24 c'est résolu.
J'ai essayé de modifier ton code mais sans résultat probant. Seul le deuxième chiffre a été mis en forme.
Cordialement

[anasecu]

re

J'ai essayé de modifier ton code mais sans résultat probant. Seul le deuxième chiffre a été mis en forme.

Normal car tu as mis 2 fois [B14]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

        Set c1 = [F1]: Set c2 = [A2]: Set c3 = [B14]

Il te faut corriger et remettre ton [B4]

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

        Set c1 = [F1]: Set c2 = [A2]: Set c3 = [B4]

[lmc71]

Re
J'ai mis B14 car je ne veux qu'une seule phrase et non pas deux, car B4 est le 24 qui est formaté et B14 c'est le 6 qui l'est.
Je dois probablement en déduire qu'il est impossible (à mon niveau) d'avoir une seule phrase avec deux formatages ou plus, sinon par bidouillage.
Cordialement

[anasecu]

Bonsoir lmc71,

Je dois probablement en déduire qu'il est impossible (à mon niveau) d'avoir une seule phrase avec deux formatages ou plus

Tu peux avoir plusieurs formatages sur la même cellule et j'ai modifié le code ci-joint en ce sens.
Cependant, il te faut savoir que même si la mise en forme se fait avec le calcul de la formule, les cellules modifiables ne peuvent être que des cellules de texte non résultat de formule. Par contre si le résultat change, l'ancienne mise en forme ne change pas : faudrait-il remettre à normal ?

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Private Sub Worksheet_Calculate()
Const nbf = 8   ' nombre de formats à adapter
Dim idx As Integer, tdc As Long
tdc = Application.Calculation
Application.Calculation = xlCalculationManual
ReDim cdf(1 To nbf, 1 To 3)
If [F1] <> "" Then
    idx = idx + 1: cdf(idx, 1) = "B4": cdf(idx, 2) = "F1"
    cdf(idx, 3) = InStr(Range(cdf(idx, 1)), Range(cdf(idx, 2)))
End If
If [F1] <> "" Then
    idx = idx + 1: cdf(idx, 1) = "B14": cdf(idx, 2) = "F1"
    cdf(idx, 3) = InStr(Range(cdf(idx, 1)), Range(cdf(idx, 2)))
End If
If [F2] <> "" Then
    idx = idx + 1: cdf(idx, 1) = "B14": cdf(idx, 2) = "F2"
    cdf(idx, 3) = InStr(Range(cdf(idx, 1)), Range(cdf(idx, 2)))
End If
If [F2] <> "" Then
    idx = idx + 1: cdf(idx, 1) = "B14": cdf(idx, 2) = "F3"
    cdf(idx, 3) = InStr(Range(cdf(idx, 1)), Range(cdf(idx, 2)))
End If
For idx = 1 To UBound(cdf)
    If cdf(idx, 1) <> "" And cdf(idx, 3) > 0 Then
        With ActiveSheet.Range(cdf(idx, 1)).Characters(cdf(idx, 3), Len(Range(cdf(idx, 2)))).Font
          .ColorIndex = 3 'rouge
          .Bold = True 'gras
          .Size = 20
        End With
    End If
Next idx
Application.Calculation = tdc
End Sub

Tu as dans ce code 3 mises en forme sur B14.

[lmc71]

Bonjour,
J'ai essayer ton dernier code (fichier joint) et comme tu le dis ce n'est pas des plus concluant. Car même en reformant le cellule B14 l'effet n'est pas réel.
Je pense qu'il faut laisser le dossier en l'état.......
Cordialement

[anasecu]

Bonjour,

comme tu le dis ce n'est pas des plus concluant.

Voilà le code en ne mettant en valeur que les cellules qui correspondent :

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
Private Sub Worksheet_Calculate()
Const nbf = 8   ' nombre de formats à adapter
Dim idx As Integer, tdc As Long
[B14].Value = [A2].Value
tdc = Application.Calculation
Application.Calculation = xlCalculationManual
ReDim cdf(1 To nbf, 1 To 3)
If [F1] <> "" Then
    idx = idx + 1: cdf(idx, 1) = "B4": cdf(idx, 2) = "F1"
    cdf(idx, 3) = InStr(Range(cdf(idx, 1)), Range(cdf(idx, 2)))
End If
If [F1] <> "" Then
    idx = idx + 1: cdf(idx, 1) = "B14": cdf(idx, 2) = "F1"
    cdf(idx, 3) = InStr(Range(cdf(idx, 1)), Range(cdf(idx, 2)))
End If
If [F2] <> "" Then
    idx = idx + 1: cdf(idx, 1) = "B14": cdf(idx, 2) = "F2"
    cdf(idx, 3) = InStr(Range(cdf(idx, 1)), Range(cdf(idx, 2)))
End If
If [F3] <> "" Then
    idx = idx + 1: cdf(idx, 1) = "B14": cdf(idx, 2) = "F3"
    cdf(idx, 3) = InStr(Range(cdf(idx, 1)), Range(cdf(idx, 2)))
End If
For idx = 1 To UBound(cdf)
    If cdf(idx, 1) <> "" Then
        With ActiveSheet.Range(cdf(idx, 1)).Font
              .Color = 0  ' noir
              .Bold = False 'gras
              .Size = 11
            End With
    End If
Next idx
For idx = 1 To UBound(cdf)
    If cdf(idx, 1) <> "" And cdf(idx, 3) > 0 Then
        With ActiveSheet.Range(cdf(idx, 1)).Characters(cdf(idx, 3), Len(Range(cdf(idx, 2)))).Font
          .ColorIndex = 3 'rouge
          .Bold = True 'gras
          .Size = 20
        End With
    End If
Next idx
Application.Calculation = tdc
End Sub

Pour utiliser des cellules formulées comme ton A2, il suffit de rajouter en début de module la copie valeur de la cellule avec formule

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

[B14].Value = [A2].Value

[mercatog]

Bonjour

Une autre manière de formater les chiffres dans une phrase

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Private Sub Worksheet_Calculate()
 
[B14] = [A2]
Formatage [B14]
End Sub
 
Private Sub Formatage(Target As Range)
Dim i As Integer, N As Integer
Dim Tb
 
Tb = Split(Target)
For i = 0 To UBound(Tb)
    If Val(Tb(i)) <> 0 Then
        With Target.Characters(N + 1, Len(Tb(i))).Font
            .ColorIndex = 3                                'rouge
            .Bold = True                                   'gras
            .Size = 20
        End With
    End If
    N = N + Len(Tb(i)) + 1
Next i
End Sub

[mercatog]

Ou simplement

Code :

Sélectionner tout - Visualiser dans une fenêtre à part

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
Private Sub Worksheet_Calculate()
 
Application.ScreenUpdating = False
[B14] = [A2]
Formatage [B14]
End Sub
 
Private Sub Formatage(Target As Range)
Dim Tmp As String
Dim i As Integer
 
Tmp = Target.Value
For i = 1 To Len(Tmp)
    If IsNumeric(Mid(Tmp, i, 1)) Then
        With Target.Characters(i, 1).Font
            .ColorIndex = 3                                'rouge
            .Bold = True                                   'gras
            .Size = 20
        End With
    End If
Next i
End Sub

[lmc71]

Bonjour Mercatog, Anasecu
J'ai essayé les codes de Mercatog et placés dans mon fichier initial et tout fonctionne très bien.
Je conserve néanmoins les codes d'Anasecu pour mon apprentissage personnel.
Je tiens à vous remercier tous les deux pour votre obligeance qui dénote votre bienveillance.
Cordialement
Je vais mettre affaire résolue.
Encore merci