VBA code for a specific conditional formatting adjusting bar lengths base on values of another range [excel VBA]

Question

I want a VBA code that creates me data bar but the length of the bar be base on the values in another range, while showing me the values of the current range in each cell.

To clarify, imagine some cells have the values groupA=[1,2,-1,3,5,-2,-4] and some other cells with these value groupB=[5,-1,2,3,-1,2,1]. what I want here is to create some bars on range groupA base on values of groupB, while I see the initial values of groupA.

this way I can realize the effect of values of groupA on my results and adjust my parameters.

So far, I manage to write the basics of my code and unfortunately I was not successful in adding the modification to it. If anyone can help me to modify this code then it is a great help for me.

Sub databars()
Dim rg As Range
Dim db As Databar


Set rg = Range("A1", Range("A1").End(xlDown))
rg.FormatConditions.Delete
Set db = rg.FormatConditions.AddDatabar


With db
    'positive bar formatted with black gradient & black border
    .BarColor.color = RGB(0, 0, 255)
    .BarFillType = xlDataBarFillGradient
    .BarBorder.Type = xlDataBarFillGradient
    .BarBorder.color.color = vbBlack
    'the axis positioned automatically and coloured red
    .AxisPosition = xlDataBarAxisAutomatic
    .AxisColor.color = vbRed
    'the negative bar formatted with a red gradient and red border
    With .NegativeBarFormat
        .ColorType = xlDataBarColor
        .color.color = vbRed
        .BorderColorType = xlDataBarColor
        .BorderColor.color = vbRed
    End With
End With
End Sub

ChatGPT, thinks it is possible but unfortunately the code it suggests is with some errors which I cannot resolve them. I am going to write its suggestion here, maybe it can help a little bit.

'Sub ApplyDataBarsWithValuesFromGroupB()
Dim groupA As Range
Dim groupB As Range
Dim cellA As Range
Dim cellB As Range
Dim maxValueB As Double
Dim scaleFactor As Double
Dim dataBarRule As Databar

' Set the ranges for Group A and Group B
Set groupA = Range("A1:A7")
Set groupB = Range("B1:B7")

' Determine the maximum value in Group B
maxValueB = Application.WorksheetFunction.Max(groupB)

' Calculate the scaling factor for data bars
scaleFactor = 100 ' Adjust this factor as needed

' Apply data bars to Group A based on values from Group B
For Each cellA In groupA
    ' Get the corresponding value from Group B
    Set cellB = groupB.Cells(cellA.Row, 1)
    
    ' Calculate the scaled value for data bars
    Dim scaledValue As Double
    scaledValue = (cellB.Value / maxValueB) * scaleFactor
    
    ' Apply conditional formatting using scaled values
    Set dataBarRule = cellA.FormatConditions.AddDatabar
    dataBarRule.MinPoint.Modify newtype:=xlConditionValueAutomaticMin
    dataBarRule.MaxPoint.Modify newtype:=xlConditionValueAutomaticMax
    dataBarRule.DataBar.PercentMin = 0
    dataBarRule.DataBar.PercentMax = scaledValue
    
    ' Show the original value in the cell as text
    cellA.Value = cellA.Value & " (" & cellB.Value & ")"
Next cellA

End Sub'

Answer 1

Here's a slightly different approach using shapes overlaid on the cells instead of CF databars:

Sub UpdateBars()
    
    Dim rng As Range, rngV As Range, c As Range, mx As Double, mn As Double
    Dim shp As Shape, nm As String, i As Long, v
    
    Set rng = Sheet4.Range("A1:A30")  '(eg) range with bars
    Set rngV = rng.Offset(0, 1)       '(eg) range with values for the bars
    
    mx = Application.max(rngV)  'get values range max/min
    mn = Application.min(rngV)
    
    For i = 1 To rng.Cells.Count 'loop over the range where the bars need to be
        Set c = rng.Cells(i)
        nm = "databar" & c.Address(False, False)  'name for the shape
        Set shp = Nothing                         'clear any previous shape reference
        On Error Resume Next                      'ignore error if no bar
        Set shp = c.Parent.Shapes(nm)
        On Error GoTo 0                           'stop ignoring errors
        If shp Is Nothing Then                    'is there an existing bar?
            'no existing bar - add and format
            Set shp = c.Worksheet.Shapes.AddShape(msoShapeRectangle, _
                             c.Left + 1, c.Top + 1, c.Width - 1, c.Height - 1)
            shp.Line.Visible = msoFalse
            With shp.Fill
                .Visible = msoTrue
                .ForeColor.RGB = RGB(100, 100, 250)
                .Transparency = 0.6
            End With
            shp.Name = nm
        End If
        'adjust the bar width according the the cell in the "values" range...
        v = rngV.Cells(i).Value
        If Len(v) > 0 Then
            shp.Width = (c.Width - 2) * (v - mn) / (mx - mn)
        Else
            shp.Width = 0
        End If
    Next i
End Sub

You could use one or more events such as worksheet_change/calculate to refresh the bars.

Answer 2

As per other comments, you cannot do this with CF, but you can simulate it with a Chart. Better, this requires no VBA. This is an example of the results:

And these are the steps to create this if it works for you (you only need to do this once for all 7 rows, not once per row):

• Select the range containing the source data ('groupB' in your case)
• Add a Chart - a '2-D Bar' (Clustered Bar)
• Select the 'Vertical (category) Axis'
• In 'Axis Options', select 'Categories in reverse order' (assuming on your device, as they were on mine, each bar is initially in the wrong order)
• Then press delete to delete the Vertical Axis from the Chart
• Optionally, you can select the Horizontal (Value) Axis then in 'Axis Options' set a Minimum and Maximum bound (or leave as auto)
• Also then, one after the other select and delete: the Chart Title, the Horizontal (Value) Axis, the Horizontal Axis Gridlines
• Select the 'Plot Area' and use the 4 drag handles (one after the other) to stretch the Plot Area to fill the 'Chart Area'
• Select the 'Chart Area', in 'Fill' select 'No fill'
• Select the 'Series' (there should only be 1) then in 'Series Options', change 'Gap width' to 0%
• Still with the 'Series' selected, in 'Fill' select 'Solid fill' and adjust 'Transparency' to 30%
• Drag and re-size the Chart over the 'groupA' cells ... this is easier if you first select 'Snap to Grid' first: in the 'Page Layout' tab of the Excel ribbon: Align > Snap to Grid

Obviously, you can tweak the colours, transparency, sizes etc just as you can with any other Chart.