# all
I use the code from the following post: Changing the shape of the specific dots in scatter plot excel based on values
It works perfectly.
If I apply the slicers (filter) then the colours and the shapes do not match anymore according the inputs... I think I need to loop the input range not the series point - the question is how do I do that most efficiently?
Thanks for any help...
Sub ColorScatterPoints3()
Dim cht As Chart
Dim srs As Series
Dim pt As Point
Dim p As Long
Dim Vals$, lTrim#, rTrim#
Dim valRange As Range, cl As Range
Dim myColor As Long
Dim myShape As String
Set cht = ActiveSheet.ChartObjects(1).Chart
Set srs = cht.SeriesCollection(1)
'## Get the series Y-Values range address:
lTrim = InStrRev(srs.Formula, ",", InStrRev(srs.Formula, ",") - 1, vbBinaryCompare) + 1
rTrim = InStrRev(srs.Formula, ",")
Vals = Mid(srs.Formula, lTrim, rTrim - lTrim)
Set valRange = Range(Vals)
For p = 1 To srs.Points.Count '##If we have rows which could be filtered out then we need to loop the input range and not the series points - but how?
Set pt = srs.Points(p)
Set cl = valRange(p).Offset(0, 1) '## assume color is in the next column.
Set shp = valRange(p).Offset(0, 2) '## assume shape is in column next to color.
'Color Change
With pt.Format.Fill
.Visible = msoTrue
'.Solid 'I commented this out, but you can un-comment and it should still work
'## Assign Long color value based on the cell value
'## Add additional cases as needed.
Select Case LCase(cl)
Case "red"
myColor = RGB(255, 0, 0)
Case "green"
myColor = RGB(0, 255, 0)
Case "yellow"
myColor = RGB(255, 255, 0)
Case "orange"
myColor = RGB(255, 137, 10)
Case "blue"
myColor = RGB(0, 0, 255)
Case "purple"
myColor = RGB(150, 0, 255)
End Select
.ForeColor.RGB = myColor
End With
'Shape Change
With pt
'## Assign shape value based on the cell value
'## Add additional cases as needed.
Select Case LCase(shp)
Case "square"
myShape = xlMarkerStyleSquare
Case "triangle"
myShape = xlMarkerStyleTriangle
Case "circle"
myShape = xlMarkerStyleCircle
Case "x"
myShape = xlMarkerStyleX
Case "+"
myShape = xlMarkerStylePlus
Case "diamond"
myShape = xlMarkerStyleDiamond
Case "star"
myShape = xlMarkerStyleStar
End Select
.MarkerStyle = myShape
End With
Next
End Sub
Related
scenario is i have an array of shapes on my worksheet and i want to set a loop running through each shape setting the colour accordingly.
what i've come up with so far:
Dim yFilter(1 To 5) As String
yFilter(1) = "BD_P"
yFilter(2) = "FIN_P"
yFilter(3) = "PM_P"
yFilter(4) = "IPS_P"
yFilter(5) = "ENG_P"
Dim sh As Shape
For Each sh In ActiveSheet.Shapes
For i = 1 To 5
If sh = yFilter(i) Then
sh.Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
End With
End If
Next i
Next
the issue with the above is it's not matching sh.name it's just matching against the group shape
however if i use ActiveSheet.Shapes.Range(Array("BD_P")).Select it works fine ....i'd just rather not have to do this for every single item i'd rather have it run through as an array for example.
any ideas how i can resolve this would be appreciated.
Loop Through Shapes From List
Dim yFilter(1 To 5) As String
yFilter(1) = "BD_P"
yFilter(2) = "FIN_P"
yFilter(3) = "PM_P"
yFilter(4) = "IPS_P"
yFilter(5) = "ENG_P"
Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
Dim shp As Shape, i As Long
For i = LBound(yFilter) To UBound(yFilter)
On Error Resume Next
Set shp = ws.Shapes(yFilter(i))
On Error GoTo 0
If Not shp Is Nothing Then
shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
Set shp = Nothing
End If
Next i
after countless attempts i finally found a way to make it work
incase anyone else ever stumbles upon a similar issue:
yFilter = Array("BD_P", "FIN_P", "PM_P", "IPS_P", "ENG_P")
For Each Item In yFilter
ActiveSheet.Shapes.Range(Array(Item)).Select
With Selection.ShapeRange.Fill
.Visible = msoTrue
.ForeColor.RGB = RGB(255, 255, 255)
End With
Next
Good afternoon,
I have the problem.
By using the following function:
Private Sub SizeToRange(ByVal targetShape As Shape, ByVal Target As Range)
' Adjust picture properties
With targetShape
' Check if next line is required...
.LockAspectRatio = msoFalse
.Left = Target.Left + 15
.Top = Target.Top - 4
.Width = Target.Width - 30
.Height = Target.Height
.ZOrder msoSendToBack
'.IncrementRotation Deg
End With
' Adjust picture border properties
With targetShape.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.ForeColor.TintAndShade = 0
.ForeColor.Brightness = 0
.Transparency = 0
.Visible = msoTrue
.Weight = 1
End With
End Sub
and the code:
Public Sub ResizeChambers()
Dim targetSheet As Worksheet
Dim targetRange As Range
Dim targetShape As Shape
' Define the sheet that has the pictures
Set targetSheet = ThisWorkbook.ActiveSheet
' Define the range the images is going to fit
Set targetRange = targetSheet.Range("E3:I16")
' Loop through each Shape in Sheet
For Each targetShape In targetSheet.Shapes
' Check "picture" word in name
If targetShape.Name Like "*Picture*" Then
' Call the resize function
SizeToRange targetShape, targetRange
targetShape.Flip msoFlipHorizontal
End If
Next targetShape
End Sub
I am trying to set all my images on horizontal way.
As you can see I used both options:
1. targetShape.Flip msoFlipHorizontal for the code
2. .IncrementRotation Deg for function
In both cases doesn't work, because one images are horizontal and another ones are vertical and another way round.
How can I make all of them in horizontal alignment?
You can accomplish this in different ways, by using Shape Range Collection Object, and either use Shepes.SelectAll, or Select each type of shape object, without using the Replace argument, or select a specific Range. Change the type of shape and range as needed. If you have any questions, please ask.
Example 1: Use Shape Range collection Object
Dim shprng As ShapeRange
ActiveSheet.Shapes.SelectAll
Set shprng = Selection.ShapeRange
shprng.Align 3, 0 '3 is the enumeration for msoPicture, and 0 is the enumeration for msoFalse
Example 2: Select the type of shape
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
If shp.Type = 13 Then shp.Select False '13 is the enumeration for msoPicture
Next shp
With Selection.ShapeRange
.Align 3, 0 '3 is the enumeration for msoALignTops, and 0 is the enumeration for msoFalse
End With
Example 3: Use a specific Range
Dim shp As Shape, rng As Range
Set rng = ActiveSheet.Range("D4:O20")
For Each shp In ActiveSheet.Shapes
If Not Intersect(Range(shp.TopLeftCell, shp.BottomRightCell), rng) Is Nothing And shp.Type = 13 Then shp.Select False '13 is the enumeration for msoPicture
Next shp
With Selection.ShapeRange
.Align 3, 0 '3 is the enumeration for msoALignTops, and 0 is the enumeration for msoFalse
End With
I have this PivotChart in Excel 2016
As you can see there are two properties in the axis field: "Date" and "Category".
There are two possible values for "Category": ASC and SBT.
Right now the bars related to either values are of the same colors (Red and Blue).
I want that if the "Category" is SBT, the colors of the bars must be different (for example, yellow and green). How can I achieve that?
Thanks
Try this.
Sub test()
Dim obj As ChartObject
Dim cht As Chart
Dim pnt As Point
Dim Ws As Worksheet
Dim s As String
Set Ws = ActiveSheet
Set obj = Ws.ChartObjects(1)
Set cht = obj.Chart
With cht
.ApplyDataLabels
For Each pnt In .SeriesCollection(1).Points
With pnt.DataLabel
.ShowCategoryName = True
.ShowValue = False
End With
s = pnt.DataLabel.Text
If InStr(s, "SBT") Then
pnt.Format.Fill.ForeColor.RGB = RGB(255, 2255, 0)
End If
With pnt.DataLabel
.ShowCategoryName = False
End With
Next pnt
For Each pnt In .SeriesCollection(2).Points
With pnt.DataLabel
.ShowCategoryName = True
.ShowValue = False
End With
s = pnt.DataLabel.Text
If InStr(s, "SBT") Then
pnt.Format.Fill.ForeColor.RGB = RGB(29, 219, 22)
End If
With pnt.DataLabel
.ShowCategoryName = False
End With
Next pnt
End With
End Sub
I have this code to create a chart:
Sub CreateChart()
Dim rng As Range
Dim cht As Object
Set rng = ActiveSheet.Range("A4:C8")
Set cht = ActiveSheet.Shapes.AddChart2
cht.Chart.SetSourceData Source:=rng, PlotBy:=xlColumns
cht.Chart.ChartType = xlBarStacked
cht.SeriesCollection(1).Interior.Color = RGB(255, 255, 255)
End Sub
But the series 1 bars are not changing the color.
Can you help?
Thanks!
See answer below, it implements what you wanted in your post, in a different method, allowing you more flexibility in the future:
Option Explicit
Sub CreateChart()
Dim rng As Range
Dim cht As ChartObject
Dim cht_Series As Series
Set rng = ActiveSheet.Range("A4:C8")
' in brackets (Left, Width, Top, Height) >> modify according to your needs
Set cht = ActiveSheet.ChartObjects.Add(100, 100, 100, 100)
With cht
.Chart.SetSourceData Source:=rng
.Chart.PlotBy = xlColumns
.Chart.ChartType = xlBarStacked
End With
Set cht_Series = cht.Chart.SeriesCollection(1)
' this will result to white (by your post) >> modify to your desired color
cht_Series.Format.Fill.ForeColor.RGB = RGB(255, 255, 255)
End Sub
Try this :
Sub CreateChart()
Dim rng As Range
Set rng = ActiveSheet.Range("A4:C8")
ActiveSheet.Shapes.AddChart.Select
With ActiveChart
.SetSourceData Source:=Range("Feuil1!$A$4:$B$8")
.SeriesCollection.NewSeries
.SetSourceData Source:=rng, PlotBy:=xlColumns
.ChartType = xlBarStacked
.SeriesCollection(1).Interior.ColorIndex = 5 'Change value to change color
End With
End Sub
and choose the value in the color index table. 5 correspond to blue. You can get the color index table here .
I am trying to make some revisions to my DataLabels.
I would like the column width (Down, Up and Total) to match the size of the text. I would also like to make the data label text bolded and easier to see.
Does anyone know the best method to do this given my code and the existing chart that I have right now?
Thanks!
Sub Waterfall()
'
' Waterfall Macro
'
'
Range("A7").Select
Dim rngData As Range
Dim intCounter As Integer
Dim rngToSelect As Range
Dim srs As Series
Dim i As Long
Set rngData = ActiveCell.CurrentRegion
Set rngToSelect = Range(rngData.Cells(1, 1), rngData.Cells(rngData.Rows.Count, 1))
For intCounter = 1 To rngData.Columns.Count
If rngData.Cells(1, intCounter).Value <> "Values" Then
Set rngToSelect = Union(rngToSelect, Range(rngData.Cells(1, intCounter), rngData.Cells(rngData.Rows.Count, intCounter)))
End If
Next intCounter
rngToSelect.Select
ActiveSheet.Shapes.AddChart.Select
ActiveChart.SetSourceData Source:=rngToSelect
ActiveChart.ChartType = xlColumnStacked
ActiveChart.ChartGroups(1).GapWidth = 75
ActiveChart.SeriesCollection("Blank").Select
Selection.Format.Fill.Visible = msoFalse
For Each srs In ActiveChart.SeriesCollection
For i = 1 To UBound(srs.Values)
srs.Points(i).HasDataLabel = srs.Values(i) > 0
Next i
Next srs
ActiveChart.SeriesCollection("Blank").DataLabels.ShowValue = False
ActiveChart.SeriesCollection("Down").Interior.Color = RGB(255, 0, 0)
ActiveChart.SeriesCollection("Up").Interior.Color = RGB(0, 204, 0)
ActiveChart.Legend.LegendEntries(3).Select
Selection.delete
'Remove Gridlines
Dim axs As Axis
For Each axs In ActiveChart.Axes
axs.HasMajorGridlines = False
axs.HasMinorGridlines = False
Next
Range("A1").Select
End Sub
In order to change your data laebls text to bold try the following command:
ActiveChart.SeriesCollection("Down").DataLabels.Font.Bold = True