Is there a way to create multi-color databar in cells based on values ? and add label on top of each cell ?
Conditional formatting is complicated for this (even impossible ?). Do you think vba solution exists ?
I have data, and for each values, I associated a category from the following set : {0.2, 0.4, 0.6, 0.8, 1.0}. Based on these category values could we create the 3th column (image below)
You can use VBA to define conditional formatting in the form of data bars and custom formatting to replace values with labels. Formatted cells should contain numeric values. Sample code:
Sub FormatDataBars()
If TypeName(Selection) <> "Range" Then Exit Sub
Dim cell As Range, numfor As String, barcol As Long
With Selection
.FormatConditions.Delete
.NumberFormat = "General"
.HorizontalAlignment = xlLeft
End With
For Each cell In Selection
If IsNumeric(cell.Value) And cell.Value <> vbNullString Then
Select Case cell.Value
Case Is <= 0.2
numfor = """Very low"""
barcol = 65535
Case Is <= 0.4
numfor = """Low"""
barcol = 5296274
Case Is <= 0.6
numfor = """Medium"""
barcol = 11389944
Case Is <= 0.8
numfor = """High"""
barcol = 947698
Case Else
numfor = """Very high"""
barcol = 8061142
End Select
cell.NumberFormat = numfor
cell.FormatConditions.AddDatabar
With cell.FormatConditions(1)
.ShowValue = True
.MinPoint.Modify newtype:=xlConditionValueNumber, newvalue:=0
.MaxPoint.Modify newtype:=xlConditionValueNumber, newvalue:=1
.BarFillType = xlDataBarFillSolid
.Direction = xlContext
.barcolor.Color = barcol
.BarBorder.Type = xlDataBarBorderSolid
.BarBorder.Color.Color = barcol
End With
End If
Next cell
End Sub
Before you use this code, you must place numeric values in the cells, and select the entire area that you want to format.
Little bit vibecoded, not perfectly clean, and do not run on large sets.
Call ColoredBar with two arguments : a float value valx and a param range. Param range should follow this format (you could add rows to add configurations, and custom labels and colors, must always have 3 columns):
Option Base 1
Private Type tuple_paramx
labelx As String
valx As Double
colorx As String
End Type
Private Function extract_param_elements(valx As Variant, param_rng As Variant) As tuple_paramx 'tuple_paramx
Dim res As tuple_paramx
Dim lastCell As Range
For Each rowx In param_rng.Rows
curr_row = rowx.Value2
curr_val = curr_row(1, 2)
Set lastCell = rowx.Cells(rowx.Cells.Count)
If curr_val = valx Then
res.valx = valx
res.labelx = curr_row(1, 1)
res.colorx = lastCell.Interior.Color
extract_param_elements = res
Exit Function
End If
Next rowx
Dim res2 As tuple_paramx
res2.colorx = 1000000
res2.labelx = "PARAM INCONNU !"
res.valx = 0#
extract_param_elements = res2
End Function
Function ColoredBar(valx As Double, param_rng As Variant) 'As String
' Effectuer des calculs et déterminer la valeur à retourner
'ColoredBar = "Calculated Value" ' Remplacez par votre logique
Dim res As tuple_paramx
res = extract_param_elements(valx, param_rng)
Dim caller As Range
Set caller = Application.caller
' Obtenir la feuille de la cellule appelante
Dim callerSheet As Worksheet
Set callerSheet = caller.Worksheet
' Obtenir la ligne et la colonne de la cellule appelante
Dim callerRow As Long
Dim callerColumn As Long
callerRow = caller.Row
callerColumn = caller.Column
' Concaténer les quatre arguments en une seule chaîne avec un délimiteur (ex: "|")
Dim CombinedArgs As String
CombinedArgs = callerSheet.Name & "|" & callerRow & "|" & callerColumn & "|" & res.valx & "|" & res.colorx 'res.labelx & "|" & res.colorx
ColoredBar = res.labelx
' Appeler la sub en utilisant Evaluate avec la chaîne combinée
Dim ma_str As String
ma_str = "SetRectangularGradientx(""" & CombinedArgs & """)"
Application.Evaluate ma_str
End Function
Private Sub SetRectangularGradientx(CombinedArgs As String)
Dim Args() As String
Args = Split(CombinedArgs, "|")
' Vérifier que nous avons exactement 4 arguments
'If UBound(Args) < 3 Then
'MsgBox "Erreur : Nombre d'arguments insuffisant."
'Exit Sub
'End If
' Assigner les arguments à des variables distinctes
Dim curr_sh As String, curr_row As Double, curr_col As Double, valx As Double, colorx As String
curr_sh = Args(0)
curr_row = Args(1)
curr_col = Args(2)
valx = Args(3)
colorx = Args(4)
Dim curr_shx As Worksheet
Set curr_shx = ThisWorkbook.Worksheets(curr_sh)
Dim myRange As Range
Set myRange = curr_shx.Cells(curr_row, curr_col)
With myRange
.Font.Italic = True
End With
With myRange.Borders
.LineStyle = xlLineStyleNone
'.Weight = xlThin
'.ColorIndex = 1 ' Black color
End With
If valx < 1 Then
to_add = valx + 0.000001
With myRange.Interior
.Pattern = xlPatternLinearGradient
.Gradient.Degree = 0 ' Horizontal (gauche à droite)
.Gradient.ColorStops.Clear
' Vert à gauche (position 0 à 0.5)
With .Gradient.ColorStops.add(0)
.Color = colorx 'RGB(0, 255, 0) ' Vert pur
End With
'valx = 0.5
With .Gradient.ColorStops.add(valx)
.Color = colorx 'RGB(0, 255, 0) ' Vert pur jusqu'au milieu
End With
With .Gradient.ColorStops.add(to_add)
.Color = RGB(255, 255, 255) ' blanc pur à partir du milieu
End With
With .Gradient.ColorStops.add(1)
.Color = RGB(255, 255, 255) ' blanc pur
End With
End With
Else
to_add = 1
With myRange.Interior
.Color = colorx
End With
End If
End Sub