Excel VBA Create Chart

[kashif.special2005]

Hi,

I have data in one data sheet name "NTWK" and I have another sheet name "NTWK - Charts", and in the Charts sheet I want to create charts from the data sheet through VBA.

Note:- The chart title will be concatenation of columns "Installed Capacity" and "Measurement Period".

I have upload the example data and example chart workbook in the dropbox and below the link for the same.

https://www.dropbox.com/s/uysgsfom4p32i6d/Chart Example (MrExcel.com).xlsm?dl=0

I don't know how can I create charts with vba and arrange that charts with the same size and in order, just like I showed in the example data.

Please help me to achieve this task.

Thanks
Kashif

 

[frank_AL]

kashif,

I have built code for a similar project in the past. I will create a solution for you. Might take a day or two due to prior commitments.

Frank_al

 

[kashif.special2005]

Hi frank_AL

Thanks for reply, though it is an urgent requirement.

As you are busy, I can wait.

Could you please tell me one thing if a sheet have many charts, then how can I identify last charts position as a range address

Thanks
Kashif

 

[frank_AL]

When I developed my code in the past I discovered that defining a chart is done by pixel rather than cell ID. This is one of those issues that I expect most developers hope for Microsoft providing an easier solution but don't hold your breath.

So when creating a chart you can define the left, width, top and height characteristics of the chart. I downloaded your file (which helps greatly) and looking at the NTWK - Charts worksheet you can left click on the vertical line between column IDs as if you are going to change the column width you will see 2 values e.g., "Width: 8.0 (80 pixels)". So for your first chart the Left position would be 81 and since your example charts are 6 columns wide the width would be 480. If you have more than 1 chart per item the Left position of the next chart would be 521. It appears the second chart is about half of Column H so you would take the Left position of the first chart which was 81, add 480 for the Width of the first chart and 40 for the spacing between charts.

Top value is calculated in a similar way. The height of the rows in your file are 24 pixels so to start at Row 3 the Top value would be 41. You example charts are 9 Rows high or 9 x 24 = 216 so Height would be 216.

I hope this helps and sorry I can't finish the code. I wasn't sleeping well overnight so I developed about half the code. I can post that if you want to see where I was heading for a solution.

 

[frank_AL]

kashif,

I have a solution for you. There are 2 code modules that you need to copy. The main code module "Sub Create_Charts()" and "Sub MergeCenter()".

Sub Create_Charts()

Option Explicit
Public currchartrow As Long, chartno As Long
Sub Create_Charts()
    Dim ntwk As Worksheet
    Dim charts As Worksheet
    Dim Chartgroup As String
    Dim i As Long
    Dim x As Long
    Dim y As Long
    Dim startrow As Long
    Dim ChartRange As Range
    Dim LeftPos As Long, TopPos As Long
    Dim LastRow As Long
    Dim ChartTitle As String
    
    Set ntwk = Worksheets("NTWK")
    Set charts = Worksheets("NTWK - Charts")
    
'   Delete Existing Charts if they Exist
    With charts.ChartObjects
        If .Count > 0 Then
            .Delete
            LastRow = charts.Cells(charts.Rows.Count, "B").End(xlUp).Row
        charts.Rows("1:" & LastRow).Delete
        End If
    End With
    
'   Determine last row of data
    LastRow = ntwk.Cells(ntwk.Rows.Count, "B").End(xlUp).Row
    
    LeftPos = 51
    TopPos = 30
    
'   Determine the Chart Grouping and Number of Charts per Group
    currchartrow = 1
'   Determine Left and Top Position of Chart
    LeftPos = 51
    TopPos = 30
    i = 2
'    i = 4
    For i = 2 To LastRow
        With ntwk
'            x = i
            If ntwk.Cells(i, 2).Interior.ColorIndex = 36 Then
                Chartgroup = .Cells(i, 2).Value
                startrow = i + 1
                x = startrow
            End If
            chartno = 0
            Do Until ntwk.Cells(x, 2).Interior.ColorIndex = 36 And x > startrow And x <= LastRow
                chartno = chartno + 1
                If ntwk.Cells(x, 2).Interior.ColorIndex = 36 And x = startrow Then
                    Chartgroup = .Cells(i, 2).Value & " - " & .Cells(x, 2).Value
                    startrow = startrow + 1
                    chartno = chartno - 1
                End If
                x = x + 1
                If x > LastRow Then
                    GoTo exitloop
                End If
            Loop
exitloop:
            i = x - 1
            chartno = chartno - 1
            
'   Create Charts
            For y = startrow To startrow + chartno
                ChartTitle = ntwk.Cells(y, 2).Value & " - " & ntwk.Cells(y, 3).Value
                charts.Cells(currchartrow, 2) = Chartgroup
                Call MergeCenter
                Set ChartRange = Sheets("NTWK").Range("D" & y & ":H" & y)
                With charts.ChartObjects.Add _
                    (Left:=LeftPos, Width:=250, Top:=TopPos, Height:=150)
                    .Chart.SetSourceData Source:=ChartRange
                    .Chart.ChartType = xlLineMarkers
                    .Chart.HasLegend = False
                    .Chart.SeriesCollection(1).HasDataLabels = False
                    .Chart.SeriesCollection(1).MarkerSize = 8
                    .Chart.HasAxis(xlValue, xlPrimary) = True
                    .Chart.HasTitle = True
                    .Chart.ChartTitle.Text = ChartTitle
                     With .Border
                         .Color = RGB(79, 129, 189)
                        .Weight = 1.5
                        .LineStyle = xlContinuous
                     End With
                End With
                If y < startrow + chartno Then
                    LeftPos = LeftPos + 300
                Else
                    LeftPos = 51
                    TopPos = TopPos + 210
                    currchartrow = currchartrow + 14
                End If
                
            Next y
        End With
    Next i
       
End Sub

Sub MergeCenter()

Option Explicit


Sub MergeCenter()
    chartno = chartno + 1
    Range(Cells(currchartrow, 2), Cells(currchartrow, chartno * 7)).Select
    chartno = chartno - 1
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlBottom
        .WrapText = False
        .Orientation = 0
        .AddIndent = False
        .IndentLevel = 0
        .ShrinkToFit = False
        .ReadingOrder = xlContext
        .MergeCells = False
    End With
    Selection.Merge
    Selection.Borders(xlDiagonalDown).LineStyle = xlNone
    Selection.Borders(xlDiagonalUp).LineStyle = xlNone
    With Selection.Borders(xlEdgeLeft)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeTop)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeBottom)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    With Selection.Borders(xlEdgeRight)
        .LineStyle = xlContinuous
        .ColorIndex = 0
        .TintAndShade = 0
        .Weight = xlMedium
    End With
    Selection.Borders(xlInsideVertical).LineStyle = xlNone
    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone
    Selection.Font.Bold = True
    Selection.Font.Size = 16
End Sub