I have the below table for which I am creating a chart:
After adding the chart I want to color the chart bars based on the label values and if the value of the label is 0 then the label should be changed to "OFF".
Below is my code to do so:
Dim ChartRng As Range
Set ChartRng = Worksheets("Overview").Range("A1:C19")
Dim oChtObj As ChartObject
Set oChtObj = Worksheets("Overview").ChartObjects.Add(Left:=48, Width:=570, Top:=1000, Height:=367)
With oChtObj.Chart
.Parent.Name = "Performance"
.ChartType = xlColumnClustered
.ApplyLayout (1)
.SetSourceData ChartRng
.HasLegend = True
.SeriesCollection(1).HasDataLabels = True
.SeriesCollection(2).HasDataLabels = False
.HasTitle = True
.ChartTitle.Caption = "Call Facing Time (KPI: 75%) Per Agent"
.ChartTitle.Font.Size = 16
.ChartTitle.Font.Color = RGB(84, 84, 84)
.SeriesCollection(1).Name = "CFT"
.SeriesCollection(2).Name = "KPI"
.SeriesCollection(2).ChartType = xlLine
.ChartStyle = 26
.Axes(xlCategory).HasMinorGridlines = False
.Axes(xlCategory).HasMajorGridlines = False
.Axes(xlValue).HasMinorGridlines = False
.Legend.LegendEntries(1).Delete
.SeriesCollection(2).Border.Color = RGB(37, 64, 97)
.SeriesCollection(2).Format.Line.Weight = 3
.Axes(xlValue).TickLabels.Font.Size = 9
.Axes(xlCategory).TickLabels.Font.Size = 9
.Axes(xlValue).TickLabels.Font.Color = RGB(77, 77, 77)
.Axes(xlCategory).TickLabels.Font.Color = RGB(77, 77, 77)
.Legend.Position = xlBottom
.Legend.Font.Size = 9
.SeriesCollection(1).DataLabels.Font.Size = 9
.ChartArea.Border.Color = RGB(217, 217, 217)
.Axes(xlValue).MajorGridlines.Border.Color = RGB(217, 217, 217)
End With
Set oChtObj = Nothing
Dim oPoint As Excel.Point
Dim sngPercente As Single
For Each oPoint In Worksheets("Overview").ChartObjects("Performance").Chart.SeriesCollection(1).Points
sngPercente = CSng(Split(oPoint.DataLabel.Caption, "%")(0))
With oPoint
If sngPercente < 70 Then
.Interior.Color = RGB(255, 0, 0)
End If
If sngPercente > 75 Then
.Interior.Color = RGB(0, 176, 80)
End If
If sngPercente >= 70 And sngPercente <= 75 Then
.Interior.Color = RGB(148, 208, 80)
End If
If sngPercente = 0 Then
.DataLabel.Caption = "OFF"
End If
End With
Next oPoint
For some reason I get the below error at the line sngPercente = CSng(Split(oPoint.DataLabel.Caption, "%")(0)):
I have also tried using Split(oPoint.DataLabel.Text but was still getting an error.
It is noteworthy that the same code was running fine when viewed in Excel 2013, however it gives the above error in 2007.
Any help understanding the reason behind the error or possible workarounds will be highly appreciated.
I am not sure if Excel 2007 has Datalabel.Caption property as I cannot test it.
Try this
Add this line
Worksheets("Overview").ChartObjects("Performance").Chart.SeriesCollection(1).HasDataLabels = True
before the For Each oPoint In Worksheets("Overview")..... Loop and now try it.
If it still doesn't work then I will delete this post.
EDIT
As per THIS this property exists in Office 2007
Further testing on Teamviewer showed that in this version you have to select the Datalabel first before reading it's value. So all we had to do was add
oPoint.DataLabel.Select
before
sngPercente = CSng(Split(oPoint.DataLabel.Caption, "%")(0))
and everything went smoothly.
Your data label shows the Y value, right? Skip the data label and go straight to the values.
Dim vYVals As Variant
Dim srs As Series
Dim iPt as Long
Dim dPctg As Double ' NO ADVANTAGE TO SINGLE OVER DOUBLE
Set srs = ActiveChart.SeriesCollection(1)
vYVals = srs.Values
For iPt = 1 to srs.Points.Count
dPctg = vYVals(iPt)
With srs.Points(iPt)
Select Case dPctg
Case 0
.DataLabel.Caption = "OFF"
Case < 0.7
.Interior.Color = RGB(255, 0, 0)
Case > 0.75
.Interior.Color = RGB(0, 176, 80)
Case Else
.Interior.Color = RGB(148, 208, 80)
End Select
End With
Next
Related
I am using a macro to insert a chart into a spreadsheet:
Option Explicit
Sub Macro1()
Dim overskrifter As Range
Dim i As Long
Dim høgde As Long, breidde As Long
Call fjernkurver
i = 1
høgde = 240: breidde = 350
Set overskrifter = Oppsummering.Range("C5:L5")
With Kurver.Shapes.AddChart2(201, xlColumnClustered)
.Name = "Graf_" & i
With .Chart.SeriesCollection.NewSeries
.XValues = overskrifter
.Values = overskrifter.Offset(i, 0)
.Name = Oppsummering.Range("B5").Offset(i, 0)
' "Olive"
.Points(1).Format.Fill.ForeColor.RGB = RGB(128, 128, 0)
' "Dark khaki"
.Points(8).Format.Fill.ForeColor.RGB = RGB(189, 183, 107)
' Green (Atlantis)
.Points(9).Format.Fill.ForeColor.RGB = RGB(146, 208, 80)
With .Format.Line
.Visible = msoTrue
.Weight = 0.5
'.ForeColor.RGB = RGB(0, 0, 205)
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
End With
.Height = høgde
.Width = breidde
.Top = 5 + ((i - 1) \ 3) * (5 + høgde)
.Left = 5 + ((i - 1) Mod 3) * (5 + breidde)
.Chart.HasTitle = True
.Chart.ChartGroups(1).GapWidth = 150
.Chart.ChartGroups(1).Overlap = 0
End With
End Sub
Sub fjernkurver()
Dim co As ChartObject
For Each co In Kurver.ChartObjects
co.Delete
Next co
End Sub
For the most part it works fine, but I am having some issues with this part of the code:
With .Format.Line
.Visible = msoTrue
.Weight = 0.5
'.ForeColor.RGB = RGB(0, 0, 205)
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
It is supposed to add a border around all the bars in the graph, red with RGB(255,0,0), blue with RGB(0,0,255).
However, as far as I can tell, no border is added to any of the bars. Can someone please point out where I am going wrong here?
The chart ends up looking like this:
It appears that the .Format.Line property of a series applies to something else than the border of a bar chart - a guess would be that it is the line connecting the datapoints of e.g. a line or scatter chart.
To actually outline the bars, I replaced the offending code;
With .Format.Line
.Visible = msoTrue
.Weight = 0.5
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
with
.Border.LineStyle = xlContinuous
.Border.Color = 9851952
.Format.Line.Weight = 0.5
Please don't ask me why .Format.Line.Weight still applies to the border, at least I got it working. Big props to the people who'd written the thread where I found the answer on Ozgrid forums.
I try to set a border to a existing powerpoint table. It runs through fine (and the row and column number is inserted in each cell as test data), but the border just does not appear. What am I doing wrong?
For i = 1 To myPresentation.Slides(w).Shapes(tableName).Table.Rows.Count
For j = 1 To myPresentation.Slides(w).Shapes(tableName).Table.Columns.Count
myPresentation.Slides(w).Shapes(tableName).Table.Cell(i, j).Shape.TextFrame.TextRange.Text = "R:" & i & " C:" & j
With myPresentation.Slides(w).Shapes(tableName).Table.Cell(i, j)
.Borders(ppBorderTop).DashStyle = msoLineSolid
.Borders(ppBorderBottom).DashStyle = msoLineSolid
.Borders(ppBorderLeft).DashStyle = msoLineSolid
.Borders(ppBorderRight).DashStyle = msoLineSolid
.Borders(ppBorderTop).ForeColor.RGB = RGB(255, 110, 0)
.Borders(ppBorderBottom).ForeColor.RGB = RGB(255, 110, 0)
.Borders(ppBorderLeft).ForeColor.RGB = RGB(255, 110, 0)
.Borders(ppBorderRight).ForeColor.RGB = RGB(255, 110, 0)
.Borders(ppBorderBottom).Weight = 1
.Borders(ppBorderTop).Weight = 1
.Borders(ppBorderLeft).Weight = 1
.Borders(ppBorderRight).Weight = 1
.Borders(ppBorderBottom).Visible = msoTrue
.Borders(ppBorderTop).Visible = msoTrue
.Borders(ppBorderLeft).Visible = msoTrue
.Borders(ppBorderRight).Visible = msoTrue
End With
Next j
Next i
Create a single slide presentation and add only two tables on it. Then run this code:
Public Sub TestMe()
Dim myTable As Table
Dim sh As Shape
For Each sh In ActivePresentation.Slides(1).Shapes
Set myTable = sh.Table
myTable.Cell(1, 1).Borders(ppBorderTop).ForeColor.RGB = RGB(255, 110, 0)
Next sh
End Sub
It should work.
From there try to build a bit further.
I have been working on a macro for the past week to automatically create charts in excel. I have gotten pretty far along with it (thanks in large part to help from this website and its users), but I am stuck on a seemingly insignificant step. For some reason my line with markers graph shows up with discolorations in it. What I mean by this is that the middle fill of the marker is the standard blue that excel defaults to. I think the issue lies with the [ .Visible = msoTrue] line but no matter how I manipulate the code, I cannot make my markers one solid color.
The code is below
Sub DM1R_Graph()
Dim ws As Worksheet
For Each ws In Sheets
ws.Activate
If ws.Name <> "WSNs" Then
Dim sht As Worksheet
Dim xVals As Range, yVals As Range
Dim co As Shape, cht As Chart, s As Series
Set sht = ActiveSheet
Set co = sht.Shapes.AddChart()
Set cht = co.Chart
'remove any existing series
Do While cht.SeriesCollection.Count > 0
cht.SeriesCollection(1).Delete
Loop
cht.ChartType = xlLineMarkers
'get the extent of the XValues...
'below is the first Y axis entry (Oil)
'(change the 2nd offset number to get what you want)
Set xVals = sht.Range(sht.Range("B2"), sht.Cells(Rows.Count, "B").End(xlUp))
Set yVals = xVals.Offset(0, 2)
Set s = cht.SeriesCollection.NewSeries
s.XValues = xVals
s.Values = yVals
With s.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
.Solid
End With
With s.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
.Transparency = 0
End With
'below is the second y axis entry (Gas)
Set xVals = sht.Range(sht.Range("B2"), sht.Cells(Rows.Count, "B").End(xlUp))
Set yVals = xVals.Offset(0, 4)
Set s = cht.SeriesCollection.NewSeries
s.XValues = xVals
s.Values = yVals
With s.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
.Solid
End With
With s.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
'below is the third y axis entry (water)
Set xVals = sht.Range(sht.Range("B2"), sht.Cells(Rows.Count, "B").End(xlUp))
Set yVals = xVals.Offset(0, 5)
Set s = cht.SeriesCollection.NewSeries
s.XValues = xVals
s.Values = yVals
With s.Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 240)
.Transparency = 0
.Solid
End With
With s.Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 240)
.Transparency = 0
End With
'end Y axis entries
cht.HasLegend = True
'below applies the legend names to be whatever are in parenthesis'
cht.Legend.Select
ActiveChart.SeriesCollection(1).Name = "Oil (BO)"
ActiveChart.SeriesCollection(2).Name = "Gas (MCF)"
ActiveChart.SeriesCollection(3).Name = "Water (BW)"
'below applies the data labels
cht.SeriesCollection(1).Select
cht.SeriesCollection(1).ApplyDataLabels
cht.SeriesCollection(2).Select
cht.SeriesCollection(2).ApplyDataLabels
cht.SeriesCollection(3).Select
cht.SeriesCollection(3).ApplyDataLabels
'below orients the datalabels to either above,below,right,or left
cht.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).DataLabels.Select
Selection.Position = xlLabelPositionRight
cht.SeriesCollection(2).Select
ActiveChart.SeriesCollection(2).DataLabels.Select
Selection.Position = xlLabelPositionAbove
cht.SeriesCollection(3).Select
ActiveChart.SeriesCollection(3).DataLabels.Select
Selection.Position = xlLabelPositionLeft
'below moves the chart
Dim iChart As Long
Dim lTop As Double
lTop = ActiveSheet.Range("Q10").Top
For iChart = 1 To ActiveSheet.ChartObjects.Count
ActiveSheet.ChartObjects(iChart).Top = lTop
ActiveSheet.ChartObjects(iChart).Left = ActiveSheet.Range("Q1").Left
lTop = lTop + ActiveSheet.ChartObjects(iChart).Height + ActiveSheet.Range("5:7").Height
Next
'below deals with the chart title
cht.SetElement (msoElementChartTitleAboveChart)
With cht.ChartTitle
.Text = sht.Name & Chr(10) & "Oil,Gas, and Water Production Through Well Life "
.Characters.Font.Size = 12
End With
'below adds a filter to one column. You cannot have more than 1 filter per sheet.
Columns("L:L").Select
Selection.AutoFilter
End If
Next ws
End Sub
Below is a picture showing what I mean. You can see it obviously in the red series, but it also appears in the green and blue series as well.
I believe you need to set the MarkerBackgroundColor on the series.
s.MarkerBackgroundColor = RGB(255, 0, 0)
I am using an excel macro to build a table on a power point slide, and it is incredibly slow iterating through cell (about 1-2 second for each cell). Is there a way to make this process go faster? Here is my Code:
Private Function formatTable(shp As PowerPoint.Shape)
Dim i As Byte
Dim j As Byte
Dim k As Byte
Dim tabCol As Byte
With shp.Table
tabCol = .Columns.Count
For i = 1 To .Rows.Count
For j = 1 To tabCol
With .Cell(i, j).Shape
.TextFrame2.TextRange.Font.Bold = msoTrue
Select Case i
Case 1 ' Header Row
.Fill.ForeColor.RGB = RGB(128, 128, 128)
Case 2, 6, 10, 14, 19 'Elements
.Fill.ForeColor.RGB = RGB(192, 192, 192)
Case 23 'Satisfaction
.Fill.ForeColor.RGB = RGB(255, 255, 153)
Case 27, 29, 31 'Future Behaviors
.Fill.ForeColor.RGB = RGB(204, 255, 104)
Case Else
.Fill.ForeColor.RGB = RGB(255, 255, 255)
.TextFrame2.TextRange.Font.Bold = msoFalse
End Select
With .TextFrame2.TextRange.Font
.Name = "Arial"
.Fill.ForeColor.RGB = IIf(i = 1, vbWhite, vbBlack)
.Size = IIf(j <> 1 And i = 1, 7, 8)
End With
.TextFrame.TextRange.ParagraphFormat.Alignment = IIf(j = 1, ppAlignLeft, ppAlignCenter)
End With
With .Cell(i, j)
.Borders(ppBorderBottom).Weight = 1
.Borders(ppBorderTop).Weight = 1
.Borders(ppBorderLeft).Weight = 1
.Borders(ppBorderRight).Weight = 1
End With
Next
Next
End With
End Function
Unfortunately that is the only way that I know of coloring the cells in a table. I.e. via looping. However you can reduce the time drastically :)
Did you notice the Case Else part? That is the majority of the table. So you can actually remove that from the code and color the entire table in one go using the below code
oPPSlide.Shapes(1).Table.Background.Fill.ForeColor.RGB = RGB(255, 255, 255)
and you can remove the Case Else part. So you will have to loop less. In fact, it will drastically reduce the overall time. See this example that I created.
Sub Sample()
Dim oPPApp As New PowerPoint.Application
Dim oPPPrsn As PowerPoint.Presentation
Dim oPPSlide As PowerPoint.Slide
Dim FlName As String
'~~> Change this to the relevant file
FlName = "C:\Users\Siddharth Rout\Documents\MyFile.PPTX"
oPPApp.Visible = True
'~~> Open the relevant powerpoint file
Set oPPPrsn = oPPApp.Presentations.Open(FlName)
'~~> Change this to the relevant slide which has the shape
Set oPPSlide = oPPPrsn.Slides(1)
'~~> Change the background of the table in one go
oPPSlide.Shapes(1).Table.Background.Fill.ForeColor.RGB = RGB(255, 255, 255)
formatTable oPPSlide.Shapes(1)
'
'~~> Rest of the code
'
End Sub
Private Function formatTable(shp As PowerPoint.Shape)
Dim i As Long, j As Long, k As Long, tabCol As Long
With shp.Table
tabCol = .Columns.Count
For i = 1 To .Rows.Count
For j = 1 To tabCol
With .Cell(i, j).Shape
.TextFrame2.TextRange.Font.Bold = msoTrue
Select Case i
Case 1: .Fill.ForeColor.RGB = RGB(128, 128, 128)
Case 2, 6, 10, 14, 19: .Fill.ForeColor.RGB = RGB(192, 192, 192)
Case 23: .Fill.ForeColor.RGB = RGB(255, 255, 153)
Case 27, 29, 31: .Fill.ForeColor.RGB = RGB(204, 255, 104)
' Case Else
' .Fill.ForeColor.RGB = RGB(255, 255, 255)
' .TextFrame2.TextRange.Font.Bold = msoFalse
End Select
With .TextFrame2.TextRange.Font
.Name = "Arial"
.Fill.ForeColor.RGB = IIf(i = 1, vbWhite, vbBlack)
.Size = IIf(j <> 1 And i = 1, 7, 8)
End With
.TextFrame.TextRange.ParagraphFormat.Alignment = IIf(j = 1, 1, 2)
End With
With .Cell(i, j)
.Borders(ppBorderBottom).Weight = 1
.Borders(ppBorderTop).Weight = 1
.Borders(ppBorderLeft).Weight = 1
.Borders(ppBorderRight).Weight = 1
End With
Next
Next
End With
End Function
I am creating a chart using VBA using a command button I have on "Sheet1", however the chart is being added to another sheet ("Sheet2").
After the chart is added, I am using the below code to color the bars based on the DataLabel values and change the DataLabels as well:
Dim oPoint As Excel.Point
Dim sngPercente As Single
For Each oPoint In Worksheets("Sheet2").ChartObjects("Performance").Chart.SeriesCollection(1).Points
oPoint.DataLabel.Select
sngPercente = CSng(Split(oPoint.DataLabel.Caption, "%")(0))
With oPoint
If sngPercente < 70 Then
.Interior.Color = RGB(255, 0, 0)
End If
If sngPercente > 75 Then
.Interior.Color = RGB(0, 176, 80)
End If
If sngPercente >= 70 And sngPercente <= 75 Then
.Interior.Color = RGB(148, 208, 80)
End If
If sngPercente = 0 Then
.DataLabel.Caption = "OFF"
End If
End With
Next oPoint
After running this code and going to "Sheet2", I notice that the chart and the last datalabel in it are still selected.
(source: gulfup.com)
How do I un/de-select this chart?
This is what I have tried:
Worksheets("Sheet2").Range("A1").Select
Does not work as the code is being run from another sheet.
ActiveChart.Deselect
Does not work at all.
Removing the oPoint.DataLabel.Select line from the code.
Not possible, because without it the code will fail with a run-time error.
SendKeys "{ESC}"
Works, but highly unreliable, as if used with other macros it will break the code, and this will give the "code execution has been interrupted" error.
Anything else that I can try?
I'd avoid the issue completely by reading the values instead of the captions:
Dim ChartRng As Range
Dim ser As Excel.Series
Set ChartRng = Worksheets("Overview").Range("A1:C19")
Dim oChtObj As ChartObject
Set oChtObj = Worksheets("Overview").ChartObjects.Add(Left:=48, Width:=570, Top:=1000, Height:=367)
With oChtObj.Chart
.Parent.Name = "Performance"
.ChartType = xlColumnClustered
.ApplyLayout (1)
.SetSourceData ChartRng
.HasLegend = True
Set ser = .SeriesCollection(1)
ser.HasDataLabels = True
.SeriesCollection(2).HasDataLabels = False
.HasTitle = True
.ChartTitle.Caption = "Call Facing Time (KPI: 75%) Per Agent"
.ChartTitle.Font.Size = 16
.ChartTitle.Font.Color = RGB(84, 84, 84)
ser.Name = "CFT"
.SeriesCollection(2).Name = "KPI"
.SeriesCollection(2).ChartType = xlLine
.ChartStyle = 26
.Axes(xlCategory).HasMinorGridlines = False
.Axes(xlCategory).HasMajorGridlines = False
.Axes(xlValue).HasMinorGridlines = False
.Legend.LegendEntries(1).Delete
.SeriesCollection(2).Border.Color = RGB(37, 64, 97)
.SeriesCollection(2).Format.Line.Weight = 3
.Axes(xlValue).TickLabels.Font.Size = 9
.Axes(xlCategory).TickLabels.Font.Size = 9
.Axes(xlValue).TickLabels.Font.Color = RGB(77, 77, 77)
.Axes(xlCategory).TickLabels.Font.Color = RGB(77, 77, 77)
.Legend.Position = xlBottom
.Legend.Font.Size = 9
ser.DataLabels.Font.Size = 9
.ChartArea.Border.Color = RGB(217, 217, 217)
.Axes(xlValue).MajorGridlines.Border.Color = RGB(217, 217, 217)
End With
Set oChtObj = Nothing
Dim oPoint As Excel.Point
Dim sngPercente As Single
With ser
For n = 1 To .Points.Count
Set oPoint = .Points(n)
sngPercente = .Values(n) * 100
With oPoint
If sngPercente < 70 Then
.Interior.Color = RGB(255, 0, 0)
End If
If sngPercente > 75 Then
.Interior.Color = RGB(0, 176, 80)
End If
If sngPercente >= 70 And sngPercente <= 75 Then
.Interior.Color = RGB(148, 208, 80)
End If
If sngPercente = 0 Then
.DataLabel.Caption = "OFF"
End If
End With
Next n
End With
One small inconsistancy here
Worksheets("Sheet2").Range("A1").Select
I notice that in your code the sheet is named "Sheet 2" with a space. Are you trying to select a cell in a sheet that doesn't exist?