couleurs conditionnelles (VBA)

Anonyme

Bonjour,

ai défini des couleurs conditionnelles de fond sur plusieurs cellules. Selon la couleur affichée je fais des calculs.

voici la fonction ColorIndexOfCF (qui a été développée par un membre de la communauté) qui donne souvent le bon résultat mais malheureusement pas toujours. Ai un pb lorsque la couleur est un rouge pur (RVB ; 255,0,0), la fonction me donne #VALEUR!

============================================================

Function ColorIndexOfCF(Rng As Range, Optional OfText As Boolean = False) As Integer

Dim AC As Integer

AC = ActiveCondition(Rng)

If AC = 0 Then

If OfText = True Then

ColorIndexOfCF = Rng.Font.ColorIndex

Else

ColorIndexOfCF = Rng.Interior.ColorIndex

End If

Else

If OfText = True Then

ColorIndexOfCF = Rng.FormatConditions(AC).Font.ColorIndex

Else

ColorIndexOfCF = Rng.FormatConditions(AC).Interior.ColorIndex

End If

End Function

Function ActiveCondition(Rng As Range) As Integer

Dim Ndx As Long

Dim FC As FormatCondition

Dim Temp As Variant

Dim Temp2 As Variant

If Rng.FormatConditions.Count = 0 Then

ActiveCondition = 0

Else

For Ndx = 1 To Rng.FormatConditions.Count

Set FC = Rng.FormatConditions(Ndx)

Select Case FC.Type

Case xlCellValue

Select Case FC.Operator

Case xlBetween

Temp = GetStrippedValue(FC.Formula1)

Temp2 = GetStrippedValue(FC.Formula2)

If IsNumeric(Temp) Then

If CDbl(Rng.Value) >= CDbl(FC.Formula1) And _

CDbl(Rng.Value) <= CDbl(FC.Formula2) Then

ActiveCondition = Ndx

Exit Function

End If

Else

If Rng.Value >= Range(Temp).Value And _

Rng.Value <= Range(Temp2).Value Then

ActiveCondition = Ndx

Exit Function

End If

Case xlGreater

Temp = GetStrippedValue(FC.Formula1)

If IsNumeric(Temp) Then

If CDbl(Rng.Value) > CDbl(FC.Formula1) Then

ActiveCondition = Ndx

Exit Function

End If

Else

If Rng.Value > Range(Temp).Value Then

ActiveCondition = Ndx

Exit Function

End If

Case xlEqual

Temp = GetStrippedValue(FC.Formula1)

If IsNumeric(Temp) Then

If CDbl(Rng.Value) = CDbl(FC.Formula1) Then

ActiveCondition = Ndx

Exit Function

End If

Else

If Rng.Value = Temp Then

ActiveCondition = Ndx

Exit Function

End If

Case xlGreaterEqual

Temp = GetStrippedValue(FC.Formula1)

If IsNumeric(Temp) Then

If CDbl(Rng.Value) >= CDbl(FC.Formula1) Then

ActiveCondition = Ndx

Exit Function

End If

Else

If Rng.Value >= Range(Temp).Value Then

ActiveCondition = Ndx

Exit Function

End If

Case xlLess

Temp = GetStrippedValue(FC.Formula1)

If IsNumeric(Temp) Then

If CDbl(Rng.Value) < CDbl(FC.Formula1) Then

ActiveCondition = Ndx

Exit Function

End If

Else

If Rng.Value < Range(Temp).Value Then

ActiveCondition = Ndx

Exit Function

End If

Case xlLessEqual

Temp = GetStrippedValue(FC.Formula1)

If IsNumeric(Temp) Then

If CDbl(Rng.Value) <= CDbl(FC.Formula1) Then

ActiveCondition = Ndx

Exit Function

End If

Else

If Rng.Value <= Range(Temp).Value Then

ActiveCondition = Ndx

Exit Function

End If

Case xlNotEqual

Temp = GetStrippedValue(FC.Formula1)

If IsNumeric(Temp) Then

If CDbl(Rng.Value) <> CDbl(FC.Formula1) Then

ActiveCondition = Ndx

Exit Function

End If

Else

If Rng.Value <> Range(Temp).Value Then

ActiveCondition = Ndx

Exit Function

End If

Case xlNotBetween

Temp = GetStrippedValue(FC.Formula1)

Temp2 = GetStrippedValue(FC.Formula2)

If IsNumeric(Temp) Then

If Not (CDbl(Rng.Value) <= CDbl(FC.Formula1)) And _

(CDbl(Rng.Value) >= CDbl(FC.Formula2)) Then

ActiveCondition = Ndx

Exit Function

End If

Else

If Not Rng.Value <= Range(Temp).Value And _

Rng.Value >= Range(Temp2).Value Then

ActiveCondition = Ndx

Exit Function

End If

Case Else

Debug.Print "UNKNOWN OPERATOR"

End Select

Case xlExpression

If Application.Evaluate(FC.Formula1) Then

ActiveCondition = Ndx

Exit Function

End If

Case Else

Debug.Print "UNKNOWN TYPE"

End Select

Next Ndx

End If

ActiveCondition = 0

End Function

Function GetStrippedValue(CF As String) As String

Dim Temp As String

If InStr(1, CF, "=", vbTextCompare) Then

If Right(CF, 2) = """""" Then

Temp = Mid(CF, 3, Len(CF) - 3)

Else

Temp = Mid(CF, 3, Len(CF) - 2)

End If

If Left(Temp, 1) = "=" Then

Temp = Mid(Temp, 2)

End If

Else

Temp = CF

End If

GetStrippedValue = Temp

End Function

Private Function GetCFInteriorColor(rngCel As Range) As Long

' Initial version from someone else

Dim strHcolor As String

' Get Hex interior color as String

strHcolor = Right("000000" & Hex(rngCel.DisplayFormat.Interior.Color), 6)

' Convert each Hex portion to a Long & pass them to the RGB function

GetCFInteriorColor = RGB(CLng("&H" & Right(strHcolor, 2)), _

CLng("&H" & Mid(strHcolor, 3, 2)), _

CLng("&H" & Left(strHcolor, 2)))

End Function

=========================================================

Question verrouillée. Cette question a été migrée à partir de la Communauté Support Microsoft. Vous pouvez voter pour indiquer si elle est utile, mais vous ne pouvez pas ajouter de commentaires ou de réponses ni suivre la question.

0 commentaires

Réponse acceptée par l’auteur de la question

DanielCo 107.1K

Bonjour,

Apparemment, VBA comporte une anomalie dans Excel 2007. Pour la première condition (=""), c'est la 3e condition qui est reprise :

Le n° de la condition est donné par Ndx. Alors que Excel 2016 gère bien cette condition :

Compare Operator, Formula1 et Formula2 pour les deux versions.

Daniel

0 commentaires

25 réponses supplémentaires

Anonyme

2018-03-07T11:25:13+00:00

ce qui est étonnant c'est qu'au début cela fonctionnait !!!
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire
Anonyme

2018-03-07T11:19:38+00:00

lorsque j'entre 19 en I1 en B93 s'affiche #VALEUR!

est-ce un bug d'Excel ?
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire
DanielCo 107.1K Points de réputation

2018-03-07T11:08:56+00:00

Regarde ici :

https://we.tl/lJlErie4tk

Daniel
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire
Anonyme

2018-03-07T05:42:20+00:00

en B87 moi aussi j'ai remplissage rouge, par contre en B93 malheureusement je n'ai pas 3 mais #VALEUR!

Si tu as 3 c'est bon.

Je ne sais comment je vais pouvoir résoudre alors.

Peut-être enregistre le fichier sur ton ordinateur et renvoie-le moi.

merci, cordialement

Richard
Cette réponse a-t-elle été utile ?

0 commentaires Aucun commentaire