I am trying to code using vba so that a series on a chart is formatted based on certain criteria. My coding is as follows
Sub CreateChart()
Dim NPOINTS As Integer
Dim NVAL(1000) As Range, XVAL(1000) As Range, YVAL(1000) As Range
Dim Score(1000) As Range
Sheets("Scenario").Select
Range("B4").Select
NPOINTS = Worksheets("Scenario").Range(Selection, Selection.End(xlDown)).Rows.Count
Set Scenario = Worksheets("Scenario")
ActiveSheet.Shapes.AddChart2(240, xlXYScatter).Select
NVAL0 = "B3"
XVAL0 = "C3"
YVAL0 = "D3"
SCORE0 = "E3"
For i = 1 To NPOINTS
Set Score(i) = Cells(Range(SCORE0).Offset(i, 0).Row, Range(SCORE0).Column)
Set NVAL(i) = Cells(Range(NVAL0).Offset(i, 0).Row, Range(NVAL0).Column)
Set XVAL(i) = Cells(Range(XVAL0).Offset(i, 0).Row, Range(XVAL0).Column)
Set YVAL(i) = Cells(Range(YVAL0).Offset(i, 0).Row, Range(YVAL0).Column)
Scorei = Score(i).Value
ActiveChart.SeriesCollection.NewSeries
ActiveChart.FullSeriesCollection(i).Name = NVAL(i)
ActiveChart.FullSeriesCollection(i).XValues = XVAL(i)
ActiveChart.FullSeriesCollection(i).Values = YVAL(i)
If Scorei <= 10 >= 0 Then
ActiveChart.SeriesCollection(i).Points.Interior.Colour = _
RGB(0, 255, 0) 'Green
ElseIf Scorei <= 30 >= 11 Then
ActiveChart.SeriesCollection(i).Points.Interior.Colour = _
RGB(0, 255, 0) 'Green
ElseIf Scorei <= 60 >= 31 Then
ActiveChart.SeriesCollection(i).Points.Interior.Colour = _
RGB(0, 255, 0) 'Green
ElseIf Scorei <= 100 >= 61 Then
ActiveChart.SeriesCollection(i).Points.Interior.Colour = _
RGB(0, 255, 0) 'Green
Else
MsgBox "ERROR :- Score out of range"
End If
Next
With ActiveChart
'chart name
.HasTitle = False
'X axis name
.Axes(xlCategory, xlPrimary).HasTitle = True
.Axes(xlCategory, xlPrimary).AxisTitle.Characters.Text = "INFLUENCE"
'y-axis name
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "IMPORTANCE"
.SetElement (msoElementLegendRight)
.Location Where:=xlLocationAsNewSheet, Name:="Priority Chart"
End With
End Sub
Unfortunately when I run it, it fails with "Object doesn't support this property or method and then when I press Debug it highlights the following line
ActiveChart.SeriesCollection(i).Points.Interior.Colour = _
RGB(0, 255, 0) 'Green
Where am I going wrong?
I appreciate any help.
just
ActiveChart.SeriesCollection(i).format.Fill.ForeColor.RGB =RGB(0, 255, 0)
The .Points() is a collection.
You will need to cycle through all its elements and change the color one by one.
The left most point is .Points(1), the right most point is .Points.count
as per: Change the Point Color in chart excel VBA
Also there is no such thing as interior colour for points.
There are 4 relevant options as per: https://msdn.microsoft.com/en-us/vba/excel-vba/articles/point-object-excel
MarkerBackgroundColor
MarkerBackgroundColorIndex
MarkerForegroundColor
MarkerForegroundColorIndex
As per comment from Jon Peltier it is not recommended to make use of the colorindex as this is a legacy from excel <2003
Related
I would like to change the colour of waterfall chart based on chart value. For example, if the value negative, put red colour. If value is positive, put green colour.
I got below code from excel vba changing bar chart color for a data point based on point value
This code works with bar chart. However, I cannot use it with waterfall as it shown error "Object doesn't support this action"
Does anyone know how to config this to use with waterfall? Any suggestion would be highly appreciated!
Thanks,
Sub color_chart()
Dim chartIterator As Integer, pointIterator As Integer, _
seriesArray() As Variant
For chartIterator = 1 To ActiveSheet.ChartObjects.Count
seriesArray = ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
chart.SeriesCollection(1).Values
For pointIterator = 1 To UBound(seriesArray)
If seriesArray(pointIterator) >= 0 Then
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _
RGB(146, 208, 80)
Else
ActiveWorkbook.Sheets("Sheet1").ChartObjects(chartIterator). _
chart.SeriesCollection(1).Points(pointIterator).Interior.Color = _
RGB(255, 0, 0)
End If
Next pointIterator
Next chartIterator
End Sub
Here is the code I used. It works with Waterfall
Sub cht_loop()
Dim i As Integer
Dim cht As Chart
Set cht = Sheets("sheet1").ChartObjects("Chart 10").Chart
For i = 1 To 5
If Sheets("Sheet1").Range("B" & i + 1).Value < 0 Then
With cht.SeriesCollection(1).Points(i).Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(192, 0, 0)
End With
Else
With cht.SeriesCollection(1).Points(i).Format.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 176, 80)
End With
End If
Next i
End Sub
So, a quick example:
Just to show what I meant in my comment.
How do I get the correct width of each legend entry in a chart? I have used the width property of the LegendEntry but this doesn't give the correct value.
For example, using the below legend:
if I check each legend entry's width using LegendEntry.Width I get the same width for each entry
A = 67, word = 67, Longer sentence = 67,
Which is obviously incorrect, it's probably assigned the longest width to all entries. So how do i get the actual width of each entry?
I know that the chart's legend entry is automatically resized according to the number of letters.
So it is an anomaly, but it seems to be necessary to adjust the number of characters to be blank. It is not an exact match, but space * 2 seems similar.
Sub setCharts(Target As Range, Cht As Chart)
Dim Srs As Series
Dim vColor, vName
Dim i As Integer, Ln As Integer, k As Integer
vColor = Array(RGB(246, 246, 246), RGB(255, 224, 140), RGB(47, 157, 39), RGB(0, 0, 0))
vName = Array("A", "Word", "Longer sentence", "stack")
Ln = Len(vName(2)) '<~~~ "Longer sentence" 's length --> Collection name
'****** The Loop statement below makes the series names the same length ******
' For i = 0 To UBound(vName)
' k = Ln - Len(vName(i))
' vName(i) = vName(i) & Space(k * 2)
' M = Len(vName(i))
' Next i
With Cht
.ChartType = xlColumnStacked
.HasLegend = True
.Legend.Position = xlLegendPositionBottom
.HasTitle = True
.ChartTitle.Text = Target.Value
.Axes(xlValue, xlPrimary).HasTitle = True
.Axes(xlValue, xlPrimary).AxisTitle.Characters.Text = "OCF Percentiles"
.Axes(xlValue).MajorUnit = 50
For Each Srs In .SeriesCollection
Srs.Delete
Next Srs
For i = 0 To 2
Set Srs = .SeriesCollection.NewSeries
With Srs
.Name = vName(i) '<~~ Collection name
.Values = Target.Offset(0, 1).Resize(3).Offset(0, i)
.XValues = Array("A", "D", "I")
.Format.Fill.ForeColor.RGB = vColor(i)
If i = 0 Then
.Format.Fill.Transparency = 0.5 '<~~~~~ Transparency was adjusted
End If
End With
Next i
Set Srs = .SeriesCollection.NewSeries
With Srs
.Name = vName(3) '<~~ Collection name
.ChartType = xlXYScatter
.Values = Target.Offset(0, 4).Resize(1, 3)
.MarkerStyle = xlMarkerStyleSquare
.MarkerBackgroundColor = vColor(3) 'vbBlack
End With
End With
End Sub
Before
After
Wrote a macro to draw line with markers plot with excel, it works well in a single macro xlsm file. But when I tried to convert it to a excel addin (xlam file) , it got a lot of bugs. All the bugs are related to the format of both X and Y coordinates, position, font type and size of chart title, and position, font type and sizeof added text. Not sure what is the reason, need to know the correct format of them. Any debug suggestions or help, really appreciated. Please see the error message and my full macro codes as the following. Thanks.
The error message is run time error '-21474627161 (800004003)': the object is no longer valid.
After you clicked the debug, the code " .left=358" was highlighted with yellow.
But you checked with excel, the plot was drawn without chart title and the add text (that I want) and the format of coordinate was not that I tried to set. Again all these errors only happen with the xlam file, the macro works well with xlms fie.
Sub strain_plot()
sh_rows = ActiveWorkbook.ActiveSheet.Range("B65535").End(xlUp).Row
For i = 1 To sh_rows
If ActiveSheet.Cells(i, 1).Value < 0.000001 Then
ActiveSheet.Cells(i, 1).Value = 1000000000# * ActiveSheet.Cells(i, 1).Value
End If
Next i
ii = sh_rows
c_name = "chart1"
On Error GoTo err:
ActiveWorkbook.ActiveSheet.ChartObjects(c_name).Delete
err:
Set ch = ActiveWorkbook.ActiveSheet.ChartObjects.Add(330, 120, 480, 270) 'set graph position and size
ch.Name = c_name
With ch.Chart
For iii = 1 To 2
.SeriesCollection.NewSeries
.SeriesCollection(iii).Values = Range(ActiveWorkbook.ActiveSheet.Cells(1, iii + 1), ActiveWorkbook.ActiveSheet.Cells(ii, iii + 1))
.SeriesCollection(iii).XValues = Range(ActiveWorkbook.ActiveSheet.Cells(1, 1), ActiveWorkbook.ActiveSheet.Cells(ii, 1))
.SeriesCollection(iii).ChartType = xlLineMarkers
Next iii
.SeriesCollection(1).Name = "[110]"
.SeriesCollection(1).MarkerStyle = 2
.SeriesCollection(1).MarkerSize = 12
.SeriesCollection(1).MarkerForegroundColor = RGB(255, 0, 0)
.SeriesCollection(1).MarkerBackgroundColor = RGB(255, 0, 0)
.SeriesCollection(1).Format.Fill.ForeColor.RGB = RGB(255, 0, 0)
.SeriesCollection(2).Name = "[001]"
.SeriesCollection(2).MarkerStyle = 2
.SeriesCollection(2).MarkerSize = 12
.SeriesCollection(2).MarkerForegroundColor = RGB(96, 96, 96)
.SeriesCollection(2).MarkerBackgroundColor = RGB(96, 96, 96)
.SeriesCollection(2).Format.Fill.ForeColor.RGB = RGB(96, 96, 96)
With .Legend
.IncludeInLayout = False
.Position = xlLegendPositionRight
.AutoScaleFont = False
.Font.Size = 14
.Top = 25
.Left = 392
.Width = 72
.Height = 40
End With
With .ChartArea.Fill
.Visible = msoTrue
.ForeColor.SchemeColor = 33
.Solid
End With
With .SeriesCollection(1).Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0) 'red
.Transparency = 0
End With
With .SeriesCollection(2).Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(96, 96, 96) 'grey
.Transparency = 0
End With
.HasTitle = True
With .ChartTitle
.Text = ActiveWorkbook.ActiveSheet.Cells(5, 8)
.Left = 358
.Top = 236
With .Font
.Name = "Tahoma"
.Size = 10
End With
End With
With .Axes(xlCategory)
.HasTitle = True
.AxisTitle.Text = "Position(nm)" 'X-axis title
.TickLabels.Font.Size = 10 'X-axis coordinate number size
.AxisTitle.Font.Size = 14 'X-axis title word font size
.TickMarkSpacing = 3
.TickLabelSpacing = 5
.TickLabels.NumberFormatLocal = "#,##0._);[red](#,##0.)"
.TickLabels.NumberFormatLocal = "#,##0_);[red](#,##0)"
.TickLabels.NumberFormatLocal = "0_);[red](0.)"
End With
With .Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Strain" 'Y-aixs title
.AxisTitle.Font.Size = 14 'y-axis title word font size
'Minimum value of Y axis
.Axes(xlValue).MinimumScale = -0.005
.Axes(xlValue).TickLabels.NumberFormatLocal = "0.0%"
End With
End With
Dim thechartobj As ChartObject
Set thechartobj = ActiveWorkbook.ActiveSheet.ChartObjects(ch.Name)
Dim thechart As Chart
Set thechart = thechartobj.Chart
Dim thetextbox As Shape
Set thetextbox = thechart.Shapes.AddTextbox(msoTextOrientationHorizontal, 688, 372, 122, 20)
With thetextbox.TextFrame.Characters
.Text = ActiveSheet.Cells(6, 8)
With .Font
.Name = "tahoma"
.Size = 10
.Bold = msoTrue
End With
End With
End Sub
I have an Excel form whose borders are in black color. I would like to change it to other color. I tried the following code:
ActiveSheet.UsedRange.Borders.Color = RGB(255, 0, 0)
It changed the borders of all cells, including those cells which did not have borders, into red. This is not what I want. I want those borders in black to turn red and the invisible borders to stay invisible. Is there a way to do it?
Just another way of doing things making use of FindFormat and ReplaceFormat properties.
Sub BordersReplace()
With ThisWorkbook.Sheets(1)
For X = xlEdgeLeft To xlEdgeRight
With Application.FindFormat.Borders(X)
.Color = 0
End With
With Application.ReplaceFormat.Borders(X)
.Color = 255
End With
.Cells.Replace What:="", Replacement:="", searchformat:=True, ReplaceFormat:=True
Application.FindFormat.Clear
Application.ReplaceFormat.Clear
Next X
End With
End Sub
Small loop involved to go through the appropriate XLBordersIndex enumeration.
Note, not clearing FindFormat and ReplaceFormat will make Excel keep working with the first used format, hence why the .Clear is nesseccary.
I myself am a little bit puzzled on why it would't work on the cells with all edges on its borders applied. For that to work use Application.FindFormat.Borders()
Thanks for Mikku's input, I got the following code to work.
Sub change_border_color()
'change the color of existing borders
Dim cell As Range
Application.ScreenUpdating = False
For Each cell In ActiveSheet.UsedRange
If cell.Borders(xlEdgeLeft).LineStyle = 1 Then
cell.Borders(xlEdgeLeft).Color = RGB(0, 0, 255)
End If
If cell.Borders(xlEdgeTop).LineStyle = 1 Then
cell.Borders(xlEdgeTop).Color = RGB(0, 0, 255)
End If
If cell.Borders(xlEdgeBottom).LineStyle = 1 Then
cell.Borders(xlEdgeBottom).Color = RGB(0, 0, 255)
End If
If cell.Borders(xlEdgeRight).LineStyle = 1 Then
cell.Borders(xlEdgeRight).Color = RGB(0, 0, 255)
End If
Next
Application.ScreenUpdating = True
End Sub
Sub chgBorderColor_On_AllSheets()
'change the color of existing borders on all sheets
Dim Current As Worksheet
Dim cell As Range
Dim Red As Integer, Green As Integer, Blue As Integer
Dim NewColor As Long
Dim i As Integer
Red = Application.InputBox("Input R component of RGB", "Line color definition", Type:=1)
Green = Application.InputBox("Input G component of RGB", "Line color definition", Type:=1)
Blue = Application.InputBox("Input B component of RGB", "Line color definition", Type:=1)
NewColor = RGB(Red, Green, Blue)
Application.ScreenUpdating = False
For Each Current In Worksheets
For Each cell In Current.UsedRange
For i = xlEdgeLeft To xlEdgeRight '7 to 10
If cell.Borders(i).LineStyle = xlContinuous Or _
cell.Borders(i).LineStyle = xlDouble Or _
cell.Borders(i).LineStyle = xlDot Or _
cell.Borders(i).LineStyle = xlDash Or _
cell.Borders(i).LineStyle = xlDashDot Or _
cell.Borders(i).LineStyle = xlDashDotDot Or _
cell.Borders(i).LineStyle = xlSlantDashDot Then
cell.Borders(i).Color = NewColor
End If
Next
Next
Next
Application.ScreenUpdating = True
End Sub
Use this:
A Loop will work fine. Currently you are setting the complete Range and changing it's border, you only need to do that with cells having any Value.
This loop will colour the Border Red if cell currently have any border.
For Each cel In ActiveSheet.UsedRange
If Not cel.Borders(xlEdgeLeft).LineStyle = 0 Then
cel.Borders.Color = RGB(255, 0, 0)
End If
Next
This loop will color the Borders where the cel have some Value.
For Each cel In ActiveSheet.UsedRange
If Not cel.Value = "" Then
cel.Borders.Color = RGB(255, 0, 0)
End If
Next
I have a macro which adds and removes (filterseries) set data series of a chart (in its own sheet) by looping through checkboxes in a separate sheet. When I add and remove them, I want to cycle the legend off then back on so that it resizes itself automatically.
I think this is just a syntax error of how I'm using the with statement.
I have a separate macro which does this for a different purpose, but it loops through chart-sheets and treats them as variables and, for some reason, it works there.
Sub ISurfSeries1Checklist()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim i As Integer
Dim c As Integer
For i = 1 To 56
If ActiveWorkbook.Sheets("Range").Cells(3 + i, 12).Value = True Then
ActiveWorkbook.Charts("I. Surf (1)").FullSeriesCollection(i).IsFiltered = False
Else 'ActiveWorkbook.Sheets("Range").Cells(3 + i, 12) = False Then
ActiveWorkbook.Charts("I. Surf (1)").FullSeriesCollection(i).IsFiltered = True
End If
Next i
For c = 51 To 56 'ActiveWorkbook.Charts("I. Surf (1)").FullSeriesCollection.Count
ActiveWorkbook.Charts("I. Surf (1)").FullSeriesCollection(c).Format.Line.Visible = msoTrue
ActiveWorkbook.Charts("I. Surf (1)").FullSeriesCollection(c).Format.Line.ForeColor.RGB = RGB(255, 0, 0)
ActiveWorkbook.Charts("I. Surf (1)").FullSeriesCollection(c).Format.Line.Transparency = 0
Next c
ActiveWorkbook.Charts("I. Surf (1)").HasLegend = False
ActiveWorkbook.Charts("I. Surf (1)").HasLegend = True
'***Below is where it stops working.***
With ActiveWorkbook.Charts("I.Surf (1)").Legend
.Font.Size = 8
.Border.Weight = xlHairline
.Border.Color = RGB(89, 89, 89)
.Interior.Color = RGB(255, 255, 255)
.Left = Cht_Sht.PlotArea.InsideLeft - Cht_Sht.Axes(xlValue).Format.Line.Weight
.Top = Cht_Sht.PlotArea.InsideTop
End With
Runtime Error '9'. Subscript out of range
on the With statement: With ActiveWorkbook.Charts("I.Surf (1)").Legend
That means a chart named "I.Surf (1)" does not exist you are probably missing the space between the dot and Surf. It should be "I. Surf (1)".
I recommend to reference the chart by a variable so you only have to use its name once. Coding rule number 1: Don't repeat yourself.
Dim ActChart As Chart
Set ActChart = ActiveWorkbook.Charts("I. Surf (1)")
This prevents typos and if you have to change it you only need to change it in one position:
Sub ISurfSeries1Checklist()
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim ActChart As Chart
Set ActChart = ActiveWorkbook.Charts("I. Surf (1)")
Dim i As Long
For i = 1 To 56
'Note that you can shorten this to:
ActChart.FullSeriesCollection(i).IsFiltered = Not (ActiveWorkbook.Sheets("Range").Cells(3 + i, 12).Value = True)
Next i
Dim c As Long
For c = 51 To 56 'ActiveWorkbook.Charts("I. Surf (1)").FullSeriesCollection.Count
With ActChart.FullSeriesCollection(c).Format.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 0, 0)
.Transparency = 0
End With
Next c
ActChart.HasLegend = False
ActChart.HasLegend = True
With ActChart.Legend
.Font.Size = 8
.Border.Weight = xlHairline
.Border.Color = RGB(89, 89, 89)
.Interior.Color = RGB(255, 255, 255)
.Left = Cht_Sht.PlotArea.InsideLeft - Cht_Sht.Axes(xlValue).Format.Line.Weight
.Top = Cht_Sht.PlotArea.InsideTop
End With
End Sub