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
LVL 43
Saqib Husain, SyedEngineerAsked:
Who is Participating?

[Product update] Infrastructure Analysis Tool is now available with Business Accounts.Learn More

x
I wear a lot of hats...

"The solutions and answers provided on Experts Exchange have been extremely helpful to me over the last few years. I wear a lot of hats - Developer, Database Administrator, Help Desk, etc., so I know a lot of things but not a lot about one thing. Experts Exchange gives me answers from people who do know a lot about one thing, in a easy to use platform." -Todd S.

SiddharthRoutCommented:
Saqib Bhai

Is the number of rows or columns gonna increase?

Sid
0
Saqib Husain, SyedEngineerAuthor Commented:
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
0
SiddharthRoutCommented:
Great. I have a theory in my mind. Let me put it to code.

Sid
0
JavaScript Best Practices

Save hours in development time and avoid common mistakes by learning the best practices to use for JavaScript.

SiddharthRoutCommented:
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
0
Saqib Husain, SyedEngineerAuthor Commented:
Jeetay raho, khush raho, lambi umr pao aur khoo saray points ikatha karo
0
SiddharthRoutCommented:
woh to theek hai par dono conditions kaise possible hai? :)

Sid
0
Saqib Husain, SyedEngineerAuthor Commented:
the left and righ justifications only apply to the partial cells and not to the 1s
0
SiddharthRoutCommented:
Ah!

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

Sid
0
SiddharthRoutCommented:
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
0
SiddharthRoutCommented:
Also please ignore the value in Col BK. That was for my reference.

Sid
0
SiddharthRoutCommented:
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
0
Saqib Husain, SyedEngineerAuthor Commented:
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
0
SiddharthRoutCommented:
>>> 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
0
SiddharthRoutCommented:
I have an idea. Would you be coloring the cells from range G to BG by any chance?

Sid
0
Saqib Husain, SyedEngineerAuthor Commented:
No. The will remain white.
0
SiddharthRoutCommented:
Got It. :) I am using a different approach. :)

See sample.

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, rngAddr 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
    rngAddr = ""
    For Each aCell In nRange
        If InStr(1, rngAddr, aCell.Address) = 0 Then
            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.Height / 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)
                            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

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
0

Experts Exchange Solution brought to you by

Your issues matter to us.

Facing a tech roadblock? Get the help and guidance you need from experienced professionals who care. Ask your question anytime, anywhere, with no hassle.

Start your 7-day free trial
Saqib Husain, SyedEngineerAuthor Commented:
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

0
Saqib Husain, SyedEngineerAuthor Commented:
Dhannewaad
0
SiddharthRoutCommented:
Mujhe khushi hui ki aapne seva ka mauka diya ;)

Sid
0
Saqib Husain, SyedEngineerAuthor Commented:
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
0
SiddharthRoutCommented:
mein bhi issi mein believe karta hoon ;)

You too have a nice weekend.

Sid
0
It's more than this solution.Get answers and train to solve all your tech problems - anytime, anywhere.Try it for free Edge Out The Competitionfor your dream job with proven skills and certifications.Get started today Stand Outas the employee with proven skills.Start learning today for free Move Your Career Forwardwith certification training in the latest technologies.Start your trial today
Microsoft Excel

From novice to tech pro — start learning today.