asked on

Macro to automatically insert a bar in each individual cell (or collectively?)

In the attached file I have to create a bar chart in cells.

The cells in question contain a number 0 to 1 which indicates the size of the bar.

Some of the bars have been inserted as samples.

If a cell has a 1 then the bar extends the entire width of the cell.

if the cell has a 0 or is blank then no bar

If the cell has a partial amount then the bar size shall be proportionately reduced with respect to the cell width.
- if the cell to the right is blank then the bar is left justified
- if the cell to the left is blank then the bar is right justified
- if both the cells to the left and right are blank then the bar is centred
- if none of the left and right cells are blank then the bar is left justified.

furthermore the color of the bars should be as per column BI.

I can use bars created one per cell but if it is not too much effort then it would be better to have one bar spanning multiple cells wherever the data is continuous.

Saqib
Automating-bar-creation.xls

SiddharthRout

Saqib Bhai

Is the number of rows or columns gonna increase?

Sid

Saqib Husain

ASKER

Definitely. This is just a sample for reference. If you can do just this much for me I can extend it to the rest of the file

Saqib

SiddharthRout

Great. I have a theory in my mind. Let me put it to code.

Sid

SiddharthRout

Quick question.

You mentioned that

If a cell has a 1 then the bar extends the entire width of the cell.

and

- if the cell to the right is blank then the bar is left justified
- if the cell to the left is blank then the bar is right justified

How would that be possible is the cell has value 1 and the left or the right cell is blank?

Sid

Saqib Husain

ASKER

Jeetay raho, khush raho, lambi umr pao aur khoo saray points ikatha karo

SiddharthRout

woh to theek hai par dono conditions kaise possible hai? :)

Sid

Saqib Husain

ASKER

the left and righ justifications only apply to the partial cells and not to the 1s

SiddharthRout

Ah!

waise mast problem le ke aaye ho. majja ayega isko solve karne mein :)

Sid

SiddharthRout

ssaqibh bhai.

Here is a sample. I have only worked for the Red bars now. The code can be duplicated for Blue bars and Yellow bars. Please test it for Red bar. If it is Ok then I will amend it for rest.

Please run the sample Sub AutomateBarCreation()

I have changed some values so that I could test it for different cells.

Sid

Code Used

Const RBar As String = "Straight Connector 1"
Const BBar As String = "Straight Connector 2"
Const YBar As String = "Straight Connector 3"

Sub AutomateBarCreation()
    Dim rRange As Range, bRange As Range, yRange As Range
    Dim ws As Worksheet
    Dim aCell As Range
    Dim cWidth As Double, cValue As Double, barWidth As Double
    Dim NewShpName As String
    Dim NewShpCounter As Long
    Dim Exitloop As Boolean
    
    Set ws = Sheets("Revised MM")
    
    Set rRange = ws.Range("G6:BG6") '<~~ Red Range
    Set bRange = ws.Range("G8:BG8,G10:BG10") '<~~ Blue Range
    Set yRange = ws.Range("G9:BG9") '<~~ Yellow Range
    
    '~~> Clear previously created shapes
    ClearBars
    
    NewShpCounter = 1
    NewShpName = "ssaqibh" & NewShpCounter
    
    '~~> Red Range
    For Each aCell In rRange
        cValue = aCell.Value
        If aCell.Value > 0 Then
            cWidth = aCell.Width
            barWidth = (cValue * cWidth)
            ws.Shapes(RBar).Copy
            aCell.Select
            ActiveSheet.Paste
            With Selection
                .Name = NewShpName
                NewShpCounter = NewShpCounter + 1
                .Top = aCell.Top + (aCell.Width / 2)
                .Left = aCell.Left
                .Width = barWidth
                
                '~~> Check for 1 or partial amount
                If aCell.Value = 1 Then
                    x = 1
                    Exitloop = False
                    
                    '~~> For continuous data
                    Do While Exitloop = False
                        If aCell.Offset(, x) <> aCell.Value Then Exitloop = True
                        cValue = aCell.Offset(, x).Value
                        cWidth = aCell.Offset(, x).Width
                        barWidth = barWidth + (cValue * cWidth)
                        x = x + 1
                        .Width = barWidth
                    Loop
                Else
                    .Width = barWidth
                    If aCell.Column <> 7 Then
                        If aCell.Offset(, -1).Value = "" And aCell.Offset(, 1).Value <> "" Then
                            .Left = .Left + cWidth - .Width
                        ElseIf aCell.Offset(, -1).Value = "" And aCell.Offset(, 1).Value = "" Then
                            .Left = .Left + (cWidth - .Width) / 2
                        End If
                    End If
                End If
            End With
        End If
    Next aCell
    
    '~~> Blue Range
    
    
    '~~> Yellow Range
    
End Sub

Sub ClearBars()
    Dim shp As Shape
    For Each shp In Sheets("Revised MM").Shapes
        If shp.Name <> RBar And shp.Name <> BBar And shp.Name <> YBar Then
            shp.Delete
        End If
    Next
End Sub

Open in new window

Automating-bar-creation-1.xls

SiddharthRout

Also please ignore the value in Col BK. That was for my reference.

Sid

SiddharthRout

If the code is correct then here is the version for all 3 bars :)

Sid

Code Used

Const RBar As String = "Straight Connector 1"
Const BBar As String = "Straight Connector 2"
Const YBar As String = "Straight Connector 3"

Dim ws As Worksheet
Dim rRange As Range, bRange As Range, yRange As Range
Dim aCell As Range
Dim cWidth As Double, cValue As Double, barWidth As Double
Dim NewShpName As String
Dim NewShpCounter As Long
Dim Exitloop As Boolean

Sub AutomateBarCreation()
    Set ws = Sheets("Revised MM")
    
    Set rRange = ws.Range("G6:BG6") '<~~ Red Range
    Set bRange = ws.Range("G8:BG8,G10:BG10") '<~~ Blue Range
    Set yRange = ws.Range("G9:BG9") '<~~ Yellow Range
    
    '~~> Clear previously created shapes
    ClearBars
    
    NewShpCounter = 1
    NewShpName = "ssaqibh" & NewShpCounter
    
    '~~> Red Range
    Createbars RBar, rRange
    
    '~~> Blue Range
    Createbars BBar, bRange

    
    '~~> Yellow Range
    Createbars YBar, yRange
    
End Sub

Sub Createbars(nBar As String, nRange As Range)
    '~~> Red Range
    For Each aCell In nRange
        cValue = aCell.Value
        If aCell.Value > 0 Then
            cWidth = aCell.Width
            barWidth = (cValue * cWidth)
            ws.Shapes(nBar).Copy
            aCell.Select
            ActiveSheet.Paste
            With Selection
                .Name = NewShpName
                NewShpCounter = NewShpCounter + 1
                .Top = aCell.Top + (aCell.Width / 2)
                .Left = aCell.Left
                .Width = barWidth
                
                '~~> Check for 1 or partial amount
                If aCell.Value = 1 Then
                    x = 1
                    Exitloop = False
                    
                    '~~> For continuous data
                    Do While Exitloop = False
                        If aCell.Offset(, x) <> aCell.Value Then Exitloop = True
                        cValue = aCell.Offset(, x).Value
                        cWidth = aCell.Offset(, x).Width
                        barWidth = barWidth + (cValue * cWidth)
                        x = x + 1
                        .Width = barWidth
                    Loop
                Else
                    .Width = barWidth
                    If aCell.Column <> 7 Then
                        If aCell.Offset(, -1).Value = "" And aCell.Offset(, 1).Value <> "" Then
                            .Left = .Left + cWidth - .Width
                        ElseIf aCell.Offset(, -1).Value = "" And aCell.Offset(, 1).Value = "" Then
                            .Left = .Left + (cWidth - .Width) / 2
                        End If
                    End If
                End If
            End With
        End If
    Next aCell
End Sub

Sub ClearBars()
    Dim shp As Shape
    For Each shp In Sheets("Revised MM").Shapes
        If shp.Name <> RBar And shp.Name <> BBar And shp.Name <> YBar Then
            shp.Delete
        End If
    Next
End Sub

Open in new window

Automating-bar-creation-1.xls

Saqib Husain

ASKER

One correction

.Top = aCell.Top + (aCell.Width / 2)
should be
.Top = aCell.Top + (aCell.Height / 2)

The other problem is that it is neither drawing one bar per cell nor is it doing one bar for multiple cells. It ls drawing multiple bars successively overlapping.

The rest seems OK.

Saqib

SiddharthRout

>>> The other problem is that it is neither drawing one bar per cell nor is it doing one bar for multiple cells. It ls drawing multiple bars successively overlapping.

Yeah I realized that but since the macro will delete all shapes every time it is run so it won't have any effect of the size of the workbook. But still let me have a look at it.

Sid

SiddharthRout

I have an idea. Would you be coloring the cells from range G to BG by any chance?

Sid

Saqib Husain

ASKER

No. The will remain white.

ASKER CERTIFIED SOLUTION

SiddharthRout

membership

Create a free account to see this answer

Signing up is free and takes 30 seconds. No credit card required.

See answer

Saqib Husain

ASKER

Ok, now this is what I am now using

The key differences with your code are
- No separate calls for the different colors. Colors are picked on the fly. Adding new colors is easy
- Bars are not copied - they are created. So deletion before starting new is also simple
- Some of my cells have values >1 or string values. I have used 1 and 0 respectively for these cases.

In the end thankyou very much for saving my time.

Saqib

Dim ws As Worksheet
Dim rRange As Range, bRange As Range, yRange As Range
Dim aCell As Range
Dim cWidth As Double, cValue As Double, barWidth As Double
Dim NewShpName As String
Dim NewShpCounter As Long
Dim Exitloop As Boolean
Sub AutomateBarCreation()
    Set ws = Sheets("Revised MM")
    Set rRange = ws.Range("G6:BG83") '<~~ Red Range
    Sheets("Revised MM").Shapes.SelectAll
    Selection.Delete
    Createbars rRange
End Sub
Sub Createbars(nRange As Range)
    rngAddr = ""
    For Each aCell In nRange
    Clr = Cells(aCell.Row, 61)
    Select Case LCase(Clr)
        Case "blue": Clr = RGB(0, 0, 255)
        Case "red": Clr = RGB(255, 0, 0)
        Case "green": Clr = RGB(0, 255, 0)
        Case "yellow": Clr = RGB(255, 255, 0)
    End Select
        If InStr(1, rngAddr, aCell.Address) = 0 Then
            If WorksheetFunction.IsText(aCell.Value) Then cValue = 0 Else cValue = aCell.Value
            If aCell.Value > 1 Then aCell.Value = 1
            If aCell.Value > 0 Then
                cWidth = aCell.Width
                barWidth = (cValue * cWidth)
                ActiveSheet.Shapes.AddLine(aCell.Left, aCell.Top + (aCell.Height / 2), aCell.Left + barWidth, aCell.Top + (aCell.Height / 2)).Select
                Selection.ShapeRange.Line.ForeColor.RGB = Clr
                Selection.ShapeRange.Line.Weight = 6.75
                With Selection
                    '~~> Check for 1 or partial amount
                    If aCell.Value = 1 Then
                        x = 1
                        Exitloop = False
                        '~~> For continuous data
                        Do While Exitloop = False
                            If aCell.Offset(, x) <> aCell.Value Then Exitloop = True
                            cValue = aCell.Offset(, x).Value
                            cWidth = aCell.Offset(, x).Width
                            barWidth = barWidth + (cValue * cWidth)
                            rngAddr = rngAddr & aCell.Offset(, x).Address
                            x = x + 1
                            .Width = barWidth
                        Loop
                    Else
                        .Width = barWidth
                        If aCell.Column <> 7 Then
                            If aCell.Offset(, -1).Value = "" And aCell.Offset(, 1).Value <> "" Then
                                .Left = .Left + cWidth - .Width
                            ElseIf aCell.Offset(, -1).Value = "" And aCell.Offset(, 1).Value = "" Then
                                .Left = .Left + (cWidth - .Width) / 2
                            End If
                        End If
                    End If
                End With
            End If
        End If
    Next aCell
End Sub

Open in new window

Saqib Husain

ASKER

Dhannewaad

SiddharthRout

Mujhe khushi hui ki aapne seva ka mauka diya ;)

Sid

Saqib Husain

ASKER

Main ne to ab is tarah ke kaam khud se karna chhod dya hai. Hamesha EE per bhaij deta hoon. Is tarah mera kaam bhi ho jata hai aur kisi ko point bhi mil jatay hain. Jo mera time bach jata hai us mein main EE ke questions solve karne ki koshis karta hoon.

Chit bhi mera - pat bhi mera

Have a nice weekend

SiddharthRout

mein bhi issi mein believe karta hoon ;)

You too have a nice weekend.

Sid