Automating creation of salary structure floating bar chart using excel vba

 Option Explicit

Function Difference(r1 As Range, r2 As Range) As Range

Dim s As String

Dim ws As Worksheet

 

If Not (r1.Parent Is r2.Parent) Then Exit Function

On Error Resume Next

 

Set ws = Worksheets.Add

ws.Range(r1.Address) = 0

ws.Range(r2.Address).Clear

s = ws.Range(r1.Address).SpecialCells(xlCellTypeConstants).Address

Application.DisplayAlerts = False

ws.Delete

Application.DisplayAlerts = True

If s <> "" Then Set Difference = r1.Parent.Range(s)

End Function

Sub floating_bar_chart()

'so first we have to delete the sheet named HR_Chart

With Application

        .ScreenUpdating = False

        .DisplayAlerts = False

        .EnableEvents = False

    End With

   Dim achart As Chart

   

 

 For Each achart In ActiveWorkbook.Charts

    achart.Delete

  Next

   

'    With ThisWorkbook

'        Set wks = .Sheets.Add(After:=.Sheets(.Sheets.Count))

'        wks.Name = "HR_Chart"

'    End With

   

    With Application

        .ScreenUpdating = True

        .DisplayAlerts = True

        .EnableEvents = True

    End With

'first delete all charts in this sheet

Dim Chrt As ChartObject

For Each Chrt In ActiveSheet.ChartObjects

Chrt.Delete

Next

'Declare some variables

Sheets("Sheet1").Select

Dim DataRng As Range

'Dim series1name As String

'Dim series2name As String

'Dim series3name As String

'series1name = ActiveSheet.Range("F3").Value

'series2name = ActiveSheet.Range("F4").Value

'series3.Name = ActiveSheet.Range("F5").Value

Dim seriesnames()

Dim series()

ReDim Preserve seriesnames(0)

ReDim Preserve series(0)

ActiveSheet.Range("F3").Select

While ActiveCell.Value <> ""

ReDim Preserve seriesnames(UBound(seriesnames) + 1)

ReDim Preserve series(UBound(series) + 1)

Set seriesnames(UBound(seriesnames) - 1) = ActiveCell

Set series(UBound(series) - 1) = Difference(Range(Selection, Selection.End(xlToRight)), Selection)

ActiveCell.Offset(1, 0).Select

Wend

Dim counter As Integer

'For counter = 0 To (UBound(series) - 1)

'MsgBox (series(counter))

'

'Next counter

'Add a chart object, this would be an empty shell

Set Chrt = ActiveSheet.ChartObjects.Add(Left:=200, _

                                        Width:=800, _

                                        Height:=800, _

                                        Top:=50)

                                        

                                        

'set the chart name

Dim chartname As String

   

       

  

chartname = "hrchart"

Chrt.Name = chartname

'Add the series of data in your chart

 For counter = 0 To (UBound(series) - 1)

Chrt.Chart.SeriesCollection.NewSeries

 

Chrt.Chart.SeriesCollection(counter + 1).Name = "='" & ActiveSheet.Name & "'!" & seriesnames(counter).Address(, , xlR1C1)

    

    

    

Chrt.Chart.FullSeriesCollection(counter + 1).Values = "='" & ActiveSheet.Name & "'!" & series(counter).Address(, , xlR1C1)

    

Next counter

    Sheets("Sheet1").Select

    'Set Chrt = ActiveSheet.ChartObjects("hrchart")

    'moving the chart to a sheet named "HR_Chart"

    

    'Chrt.Chart.Location Where:=xlLocationAsNewSheet, Name:="HR_Chart"

    

    'move chart to new sheet at the end

   

    

  

   

  Chrt.Chart.Location Where:=xlLocationAsNewSheet, Name:="HR_Chart"

 

ActiveChart.Move After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count)

'Chrt.Chart.Location xlLocationAsObject, "HR_Chart"

ActiveChart.ChartArea.Select

    ActiveChart.FullSeriesCollection(1).Select

    ActiveChart.ChartGroups(1).Overlap = 100

   

    ActiveChart.ChartGroups(1).GapWidth = 66

    

    ActiveChart.ChartArea.Select

    ActiveChart.FullSeriesCollection(3).Select

  

    With Selection.Format.Fill

        .Visible = msoTrue

        .ForeColor.ObjectThemeColor = msoThemeColorBackground1

        .ForeColor.TintAndShade = 0

        .ForeColor.Brightness = 0

        .Transparency = 0

        .Solid

    End With

    

     ActiveChart.Axes(xlValue).MajorGridlines.Select

    Selection.Delete

  

    'ActiveSheet.ChartObjects("hrchart").Activate

    ActiveChart.FullSeriesCollection(1).Select

    ActiveChart.FullSeriesCollection(1).ApplyDataLabels

    ActiveChart.FullSeriesCollection(2).Select

    ActiveChart.FullSeriesCollection(2).ApplyDataLabels

    ActiveChart.FullSeriesCollection(3).Select

    ActiveChart.FullSeriesCollection(3).ApplyDataLabels

    

    ActiveChart.FullSeriesCollection(2).Select

    With Selection.Format.Fill

        .Visible = msoTrue

        .ForeColor.RGB = RGB(204, 229, 255)

        .Solid

    End With

'    ActiveChart.FullSeriesCollection(2).DataLabels.Select

'

'    With Selection.Format.TextFrame2.TextRange.Font.Fill

'        .Visible = msoTrue

'        .ForeColor.ObjectThemeColor = msoThemeColorBackground1

'        .ForeColor.TintAndShade = 0

'        .ForeColor.Brightness = 0

'        .Transparency = 0

'        .Solid

'    End With

    ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Visible = msoTrue

     ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.ObjectThemeColor = msoThemeColorBackground1

      ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.TintAndShade = 0

       ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.ForeColor.Brightness = 0

        ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Transparency = 0

         ActiveChart.FullSeriesCollection(2).DataLabels.Format.TextFrame2.TextRange.Font.Fill.Solid

         

         

         ActiveChart.Deselect

SendKeys "{ESC}"

DoEvents

         

End Sub