If you want to create in-cell charts using VBA . Try this macro -
Sub create_charts()
Dim i As Long
Dim cht As Shape
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("Data")
'delete all exisitng charts
For Each cht In sht.Shapes
If cht.Type = msoChart Then
cht.Delete
End If
Next
' run loop
For i = 2 To sht.Range("a65356").End(xlUp).Row
'call sub procedure to create charts
Call add_charts_to_cell("'" & sht.Name & "'!" & sht.Range("b" & i & ":e" & i).Address, sht.Range("f" & i), xlBar, "'" & sht.Name & "'!" & sht.Range("b1:e1").Address)
Call add_charts_to_cell("'" & sht.Name & "'!" & sht.Range("b" & i & ":e" & i).Address, sht.Range("g" & i), xlPie, "'" & sht.Name & "'!" & sht.Range("b1:e1").Address)
Next
End Sub
Sub add_charts_to_cell(chtdata As String, placementcell As Range, chttype As Long, chtcat As String)
Dim cht As Chart
Dim ax1 As Axis
'create chart
Set cht = ActiveSheet.ChartObjects.Add(Left:=placementcell.Left, Width:=placementcell.Width, Top:=placementcell.Top, Height:=placementcell.Height).Chart
'format the chart
On Error Resume Next
With cht
.ChartType = chttype
.HasLegend = False
.SetSourceData Source:=Range(chtdata)
.ChartArea.Border.LineStyle = xlNone
.PlotArea.Border.LineStyle = xlNone
.ChartArea.Fill.Visible = False
.PlotArea.Fill.Visible = False
.HasTitle = False
End With
'remove gridlines
For Each ax1 In cht.axes
ax1.HasMajorGridlines = False
ax1.HasMinorGridlines = False
Next
'delete axes
With cht
.axes(xlCategory).Delete
.axes(xlValue).Delete
.SeriesCollection(1).XValues = chtcat
End With
'format chart on category name
Call format_charts(cht, Range(chtcat))
End Sub
Sub format_charts(cht As Chart, formatrng As Range)
Dim rng As Range
Dim srs As Series
Dim i As Long
Set srs = cht.SeriesCollection(1)
'run loop to format chart
For i = 1 To srs.Points.Count
For Each rng In formatrng.Cells
If UCase(srs.XValues(i)) = UCase(rng.Value) Then
srs.Points(i).Interior.Color = rng.Offset(1, 0).Interior.Color
Exit For
End If
Next
Next
End Sub
Download Working File
Note :
Sub create_charts()
Dim i As Long
Dim cht As Shape
Dim sht As Worksheet
Set sht = ThisWorkbook.Sheets("Data")
'delete all exisitng charts
For Each cht In sht.Shapes
If cht.Type = msoChart Then
cht.Delete
End If
Next
' run loop
For i = 2 To sht.Range("a65356").End(xlUp).Row
'call sub procedure to create charts
Call add_charts_to_cell("'" & sht.Name & "'!" & sht.Range("b" & i & ":e" & i).Address, sht.Range("f" & i), xlBar, "'" & sht.Name & "'!" & sht.Range("b1:e1").Address)
Call add_charts_to_cell("'" & sht.Name & "'!" & sht.Range("b" & i & ":e" & i).Address, sht.Range("g" & i), xlPie, "'" & sht.Name & "'!" & sht.Range("b1:e1").Address)
Next
End Sub
Sub add_charts_to_cell(chtdata As String, placementcell As Range, chttype As Long, chtcat As String)
Dim cht As Chart
Dim ax1 As Axis
'create chart
Set cht = ActiveSheet.ChartObjects.Add(Left:=placementcell.Left, Width:=placementcell.Width, Top:=placementcell.Top, Height:=placementcell.Height).Chart
'format the chart
On Error Resume Next
With cht
.ChartType = chttype
.HasLegend = False
.SetSourceData Source:=Range(chtdata)
.ChartArea.Border.LineStyle = xlNone
.PlotArea.Border.LineStyle = xlNone
.ChartArea.Fill.Visible = False
.PlotArea.Fill.Visible = False
.HasTitle = False
End With
'remove gridlines
For Each ax1 In cht.axes
ax1.HasMajorGridlines = False
ax1.HasMinorGridlines = False
Next
'delete axes
With cht
.axes(xlCategory).Delete
.axes(xlValue).Delete
.SeriesCollection(1).XValues = chtcat
End With
'format chart on category name
Call format_charts(cht, Range(chtcat))
End Sub
Sub format_charts(cht As Chart, formatrng As Range)
Dim rng As Range
Dim srs As Series
Dim i As Long
Set srs = cht.SeriesCollection(1)
'run loop to format chart
For i = 1 To srs.Points.Count
For Each rng In formatrng.Cells
If UCase(srs.XValues(i)) = UCase(rng.Value) Then
srs.Points(i).Interior.Color = rng.Offset(1, 0).Interior.Color
Exit For
End If
Next
Next
End Sub
Download Working File
Note :
- Adjust the size of column first in which you will be adding the charts before you run the macro
- The macro will first delete all the charts on the worksheet and then it will create new in-cell charts in column F & G
- Download Sample file and make changes as per your requirement
Hi Ashish,
ReplyDeletethanks for your efforts.
when i change color of cells the color didn't change in chart!!
can you please share the sample file with us here
ReplyDeletehttp://www.facebook.com/groups/excelvbamacros/
http://www.facebook.com/EXCELVBAMACROS