Discussion :

[PokeRstarrr]

Bonjour à tous !

J'ai créer une fonction afin d'afficher un smiley différent en fonction de certaines conditions.
Tout marche bien sauf que les smileys ne s'actualise pas tout seul quand on modifie une valeur dans le tableau qui est utilisé par la fonction pour le smiley.
J'ai fais quelques recherches sur internet, et j'ai ajouter Application.Volatile afin que les smileys s'actualisent. Chose qui est réussie, mais le seul problème est que les couleurs ne suivent pas.
Par exemple, avant la modification on a un smiley content de couleur vert. Après la modification, on devrait avoir un smiley pas content de couleur rouge mais on a un smiley pas content de couleur vert.

Voilà j'espère avoir été claire, je vous montre le code pour que vous puissez m'aider :

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
44
45
46
47
48
49
50
51
Function perteRendement(valeur, cellule, feuille)
Application.Volatile
    If valeur < 15 Then
        perteRendement = "J"
        'Call smileyvert(cellule, feuille)
    ElseIf valeur >= 15 And valeur < 25 Then
        perteRendement = "K"
        'Call smileyorange(cellule, feuille)
    Else
        perteRendement = "L"
        'Call smileyrouge(cellule, feuille)
    End If
End Function
 
 
Sub smileyrouge(cellule, feuille)
 
    Sheets(feuille).Range(cellule).Select
 
    With Selection.Font
        .Name = "Wingdings"
        .Size = 20
        .Color = 255
        .Bold = True
    End With
End Sub
 
 
Sub smileyvert(cellule, feuille)
 
    Sheets(feuille).Range(cellule).Select
 
    With Selection.Font
        .Name = "Wingdings"
        .Size = 20
        .Color = 5287936
        .Bold = True
    End With
End Sub
 
Sub smileyorange(cellule, feuille)
 
    Sheets(feuille).Range(cellule).Select
 
    With Selection.Font
        .Name = "Wingdings"
        .Size = 20
        .Color = 49407
        .Bold = True
    End With
End Sub

Merci d'avance !

Cordialement,
PokeR

[mercatog]

Une mise en forme conditionnelle est faite pour ça.

Sinon, si tu tiens à ta fonction, essaies comme ceci

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
Function PerteRendement(ByVal Valeur As Double) As String
Dim Ltr As String, Klr As Long
 
Application.Volatile
If Valeur < 15 Then
    Ltr = "J"
    Klr = 255
ElseIf Valeur >= 15 And Valeur < 25 Then
    Ltr = "K"
    Klr = 5287936
Else
    Ltr = "L"
    Klr = 49407
End If
 
Application.Caller.Font.Color = Klr
PerteRendement = Ltr
End Function

[PMO2017]

Bonjour,

Une piste avec la démarche suivante :
1) copiez le code suivant dans la fenêtre de code de ThisWorkbook

Code :

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

1
2
3
4
5
6
7
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Call Colorisation(Sh)
End Sub
 
Private Sub Workbook_SheetSelectionChange(ByVal Sh As Object, ByVal Target As Range)
Call Colorisation(Sh)
End Sub

2) copiez le code suivant dans un module standard

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
44
45
46
47
48
49
50
51
52
'#####################################################
'## En cas de changement du nom de la fonction
'## changer la constante avec le nouveau nom
Public Const NOM_FONCTION As String = "perteRendement"
'#####################################################
 
Function perteRendement(Cellule As Range)
Application.Volatile
If Cellule < 15 Then
  perteRendement = "J"   'vert
ElseIf Cellule >= 15 And Cellule < 25 Then
  perteRendement = "K"   'orange
Else
  perteRendement = "L"   'rouge
End If
End Function
 
Sub Colorisation(Sh As Worksheet)
Dim R As Range
Dim C As Range
Dim couleur&
'---
Application.EnableEvents = False
On Error GoTo Erreur
Set R = Sh.Cells.SpecialCells(xlCellTypeFormulas)
For Each C In R
  If InStr(1, UCase(C.Formula), "=" & UCase(NOM_FONCTION)) Then
    If Err = 0 Then
      Select Case C
        Case "J"
          couleur& = 5287936
        Case "K"
          couleur& = 49407
        Case "L"
          couleur& = 255
      End Select
      '---
      With C.Font
        .Name = "Wingdings"
        .Size = 20
        .Color = couleur&
        .Bold = True
      End With
    Else
      Err.Clear
    End If
  End If
Next C
On Error GoTo 0
Erreur:
Application.EnableEvents = True
End Sub

Je joins un classeur exemple pour plus de facilité.