Positioning labels on a donut-chart - excel

I have the following code which attempts to add a datalabel to a point in a combined donut/pie-chart:
For Each co In .ChartObjects
With co.Chart.FullSeriesCollection("Grøn pil").Points(2)
.HasDataLabel = True
With .DataLabel
.Position = xlLabelPositionOutsideEnd
.Format.AutoShapeType = msoShapeRectangle
.Format.Line.Visible = msoTrue
End With
End With
Next co
However, the code aborts on the line .Position = xlLabelPositionOutsideEnd with the error message "Run-time error 2147467259 (80004005)". Method 'Position' of object 'DataLabel' failed".
Looking at the chart, the label has been added, but it is still positioned inside the chart.
As you can see I've already positioned a label outside the chart for a different series, which is represented as a pie chart. While the series I am trying to add the label to is represented as a donut-chart.
Can't I have both the labels for the donut- and pie-chart on the outside? Isn't xlLabelPositionOutsideEnd a valid position for labels of a donut-chart? Or is the problem something else which eludes me?
Any help would be greatly appreciated!

I don't think it's possible to do exactly you want to do the way you want to do it! The option to place the labels outside the chart is not available on the doughnut chart options:
like they do on a pie chart:
However, you could perform a trick using a pie chart and a white circle to make it look like a doughnut by doing the following:
Sub AddCircle()
'Get chart size and position:
Dim CH01 As Chart: Set CH01 = ThisWorkbook.Sheets("Sheet1").ChartObjects("Chart1").Chart
Dim OB01 As ChartObject: Set OB01 = CH01.Parent
Dim x As Double: x = 0 'horizontal coordinate
Dim y As Double: y = 0 'vertical coordinate
Dim w As Double: w = 0 'width
Dim h As Double: h = 0 'height
x = OB01.Left
y = OB01.Top
w = OB01.Width
h = OB01.Height
'Adding the circle:
ThisWorkbook.Sheets("Sheet1").Shapes.AddShape(msoShapeOval, x + w / 2 - 20, y + h / 2 - 20, 40, 40).Name = "Circle01"
'Formatting the circle:
With ThisWorkbook.Sheets("Sheet1").Shapes("Circle01")
.LINE.Visible = msoFalse
.Fill.ForeColor.RGB = RGB(255, 255, 255)
End With
End Sub
And it works very nicely:
Had some fun "solving" this one...

Working with sinus and cosinus we can also calculate the outside position of the label. Following a VB snippet, how this can be done:
Sub Macro1()
Dim cx
Dim cy
Dim x
Dim y
Dim radius
Dim angle
Dim new_radius
Dim new_x
Dim new_y
ActiveSheet.ChartObjects("Chart 1").Activate
ActiveSheet.ChartObjects("Chart 1").Select
cx = Selection.width / 2
cy = Selection.height / 2
For i = 1 To ActiveChart.FullSeriesCollection(1).Points.Count Step 1
ActiveChart.FullSeriesCollection(1).Points(i).DataLabel.Select
x = Selection.left + (Selection.width / 2)
y = Selection.top + (Selection.height / 2)
radius = Sqr(((x - cx) ^ 2) + ((y - cy) ^ 2))
angle = WorksheetFunction.Atan2(y - cy, x - cx)
new_radius = radius + 40
new_x = cx + (Sin(angle) * new_radius)
new_y = cy + (Cos(angle) * new_radius)
Selection.left = new_x - (Selection.width / 2)
Selection.top = new_y - (Selection.height / 2)
Next i
End Sub

Related

Extracting maximum value from chart axis

I have a chart sheet with 2 axis, I need to extract the maximum value of the primary axis to set the secondary one accurately. I cant seem to get the function working that will simply read the primary axis max and place it in a cell, any ideas?
This will return the max value of the left axis which is usually <> max value of original data
Public Function getAxisMaxScale(cht As Chart) As Single
Dim ax As Axis
Set ax = cht.Axes(xlValue)
getAxisMaxScale= ax.MaximumScale
End Function
To adjust the secondary axes you can use
Public sub adjustAxisForChartXYZ()
Dim cht As Chart
Set cht = ThisWorkbook.Sheets("XYZ") 'insert sheetname of your chart
adjustSecondaryAxis cht
End Sub
Public Sub adjustSecondaryAxis(cht As Chart)
Dim axPrimary As Axis, axSecondary As Axis
Set axPrimary = cht.Axes(xlValue)
Set axSecondary = cht.Axes(xlValue, xlSecondary)
With axSecondary
.MajorUnit = axPrimary.MajorUnit
.MaximumScale = axPrimary.MaximumScale
End With
End Sub
I adjust the MajorUnit as well ... to be aligned as well
This is how you get the min/max of the two series in a chart:
have chart selected and then run the following
Dim ser as SeriesCollection
' `ChartArea.Parent` = `Chart` object
Set ser = Selection.Parent.SeriesCollection()
Dim temp1() As Variant, temp2() As Variant
temp1 = ser(1).values
temp2 = ser(2).values
' Get the data limits
Dim a_1 As Double, a_2 As Double, b_1 As Double, b_2 As Double
a_1 = WorksheetFunction.Min(temp1): a_2 = WorksheetFunction.Min(temp2)
b_1 = WorksheetFunction.Max(temp1): b_2 = WorksheetFunction.Max(temp2)
This is part of a macro I developed to scale the secondary axis of chart such as the tickmarks fall on the grid of the first axis.
Before
Notice how on the secondary axis the grid for 10 through 60 is not on the gridlines shown. This makes it hard to read the chart.
After
Afterward, the grid spacing on the secondary axis is adjusted in order to match the primary axis. Also, the limits are adjusted to fill the area better.
Code
Here is the code I am using to do this.
Public Sub DualYAxisChart(ByRef ch As Chart)
Dim x_axis_1 As Axis, x_axis_2 As Axis, n As Long
Dim ser As SeriesCollection
Set ser = ch.SeriesCollection()
If ser.Count <> 2 Then
MsgBox "Please select a chart with two series", vbOKOnly, "Dual y-axis Chart"
Exit Sub
End If
If UBound(ser(1).values) <> UBound(ser(2).values) Then
MsgBox "Both series must share the same number of points", vbOKOnly, "Dual y-axis Chart"
Exit Sub
End If
n = UBound(ser(1).values)
ser(1).AxisGroup = xlPrimary
ser(2).AxisGroup = xlSecondary
' Enable Both Y-axes
ch.SetElement msoElementPrimaryValueAxisShow
ch.SetElement msoElementSecondaryValueAxisShow
' Enable Both X-axes
ch.SetElement msoElementPrimaryCategoryAxisShow
ch.SetElement msoElementSecondaryCategoryAxisShow
' Delete Secondary x-axis
ch.SetElement msoElementSecondaryCategoryAxisNone
Set x_axis_1 = ch.Axes(xlValue, xlPrimary)
Set x_axis_2 = ch.Axes(xlValue, xlSecondary)
x_axis_1.format.Line.ForeColor.RGB = ser(1).format.Line.ForeColor.RGB
x_axis_1.format.Line.EndArrowheadStyle = msoArrowheadTriangle
x_axis_2.format.Line.ForeColor.RGB = ser(2).format.Line.ForeColor.RGB
x_axis_2.format.Line.EndArrowheadStyle = msoArrowheadTriangle
' Auto Scale All
x_axis_1.MajorUnitIsAuto = True
x_axis_1.MaximumScaleIsAuto = True
x_axis_1.MinimumScaleIsAuto = True
x_axis_2.MajorUnitIsAuto = True
x_axis_2.MaximumScaleIsAuto = True
x_axis_2.MinimumScaleIsAuto = True
Dim a_1 As Double, a_2 As Double, b_1 As Double, b_2 As Double
Dim x_1 As Double, s_1 As Double, x_2 As Double, s_2 As Double, g_1 As Double, g_2 As Double
Dim n_1 As Long, n_2 As Long, sense As Long
' Get the axis limits
s_1 = x_axis_1.MinimumScale
x_1 = x_axis_1.MaximumScale
g_1 = x_axis_1.MajorUnit
n_1 = CLng((x_1 - s_1) / g_1)
s_2 = x_axis_2.MinimumScale
x_2 = x_axis_2.MaximumScale
g_2 = x_axis_2.MajorUnit
n_2 = CLng((x_2 - s_2) / g_2)
Dim temp1() As Variant, temp2() As Variant
temp1 = ser(1).values
temp2 = ser(2).values
' Get the data limits
a_1 = WorksheetFunction.Min(temp1): a_2 = WorksheetFunction.Min(temp2)
b_1 = WorksheetFunction.Max(temp1): b_2 = WorksheetFunction.Max(temp2)
sense = Sgn((b_2 - a_2) / (b_1 - a_1))
If sense < 0 Then
x_axis_2.ReversePlotOrder = True
Swap a_2, b_2
x_axis_2.format.Line.EndArrowheadStyle = msoArrowheadNone
x_axis_2.format.Line.BeginArrowheadStyle = msoArrowheadTriangle
End If
x_axis_1.MinimumScale = a_1: x_axis_1.MaximumScale = b_1
g_1 = x_axis_1.MajorUnit
n_1 = CLng((x_1 - s_1) / g_1)
x_axis_2.MinimumScale = a_2: x_axis_2.MaximumScale = b_2
g_2 = x_axis_2.MajorUnit
n_2 = CLng((x_2 - s_2) / g_2)
g_2 = (x_2 - s_2) / n_1
x_axis_2.MajorUnit = g_2
Dim i_1 As Long, i_2 As Long
i_1 = WorksheetFunction.Floor_Math(a_1 / g_1)
s_1 = i_1 * g_1
i_2 = WorksheetFunction.Floor_Math(a_2 / g_2)
s_2 = i_2 * g_2
Dim j_1 As Long, j_2 As Long
j_1 = WorksheetFunction.Ceiling_Math(b_1 / g_1)
x_1 = j_1 * g_1
j_2 = WorksheetFunction.Ceiling_Math(b_2 / g_2)
x_2 = j_2 * g_2
x_axis_1.MinimumScale = s_1: x_axis_1.MaximumScale = x_1
x_axis_2.MinimumScale = s_2: x_axis_2.MaximumScale = x_2
x_axis_1.MajorUnitIsAuto = True
g_1 = x_axis_1.MajorUnit
n_1 = CLng((x_1 - s_1) / g_1)
g_2 = (x_2 - s_2) / n_1
x_axis_2.MajorUnit = g_2
End Sub
Welcome to the board. Have a read of ASK and MCVE.
Recording a macro while manually changing the axis will give you:
Sub Macro4()
'
' Macro4 Macro
'
'
ActiveSheet.ChartObjects("Chart 2").Activate
ActiveChart.Axes(xlValue).Select
ActiveChart.Axes(xlValue).MaximumScale = 60
ActiveChart.Axes(xlValue, xlSecondary).Select
ActiveChart.Axes(xlValue, xlSecondary).MaximumScale = 90
Range("L2").Select
End Sub
The code shows that you need to reference the chart within the chart object within the sheet to get to the axis.
Sub Test()
Sheet1.ChartObjects("Chart 2").Chart.Axes(xlValue, xlSecondary).MaximumScale = _
Sheet1.ChartObjects("Chart 2").Chart.Axes(xlValue).MaximumScale
End Sub
Note - this code can be shorted using variables and a With...End With block.

Coloring Circle in Vba

I am new to Vba, I have to draw circles which are color filled in the following way
1/4 color filled circle,
Half color filled circle,
3/4 color filled circle
I know I can draw a color-filled circle with the following code
Set shpOval = ActiveSheet.Shapes.AddShape(msoShapeOval, curCellLeft, curCellTop, 20, 20)
shpOval.Fill.ForeColor.RGB = RGB(128, 0, 0)
Above code gives me a full color filled circle, which property I have to change to get circle shapes that I have mentioned above.
Just for fun: Playing around with PIE-Shapes.
Sub DrawCircle(pieces As Integer, size As Double, position As Range, color)
If pieces < 1 Then pieces = 1
If pieces > 4 Then pieces = 4
Dim varShape() As String
ReDim shapeNames(0 To pieces - 1)
Dim i As Long
For i = 0 To pieces - 1
Dim sh As Shape
Dim x As Double, y As Double
x = position.Left + IIf(i = 1 Or i = 2, size, 0)
y = position.Top + IIf(i >= 2, size, 0)
Set sh = position.Parent.Shapes.AddShape(msoShapePieWedge, x, y, size, size)
shapeNames(i) = sh.Name
sh.Rotation = i * 90
If IsArray(color) Then
sh.Fill.ForeColor.RGB = color(i + LBound(color))
Else
sh.Fill.ForeColor.RGB = color
End If
sh.Line.Visible = False
Next i
If pieces > 1 Then
position.Parent.Shapes.Range(shapeNames).Group
End If
End Sub
Playing with it:
Sub test()
Call DrawCircle(3, 20, ActiveCell, vbRed)
Call DrawCircle(4, 10, ThisWorkbook.Sheets(1).Range("F3"), Array(vbYellow, vbYellow, vbBlue, vbYellow))
Call DrawCircle(1, 40, ActiveCell.Offset(2, 2), vbGreen)
End Sub
Create a range of values in excel from A1 to A4 as 25,50,75,100. Go to Insert and select "Doughnut" chart.

Add a single data point to a series and specify its properties in VBA

Background
I'm receiving StdOut from python in and parsing the information so I have a set have N many (x,y) coordinates belonging to M many series. I would like to be able to plot each point individually and control for their respective properties I.e color, shape, marker size, etc.
However, all the examples I have seen so far involve having to plot all the values at once and then loop through the series. My desired functionality would look like the below pseudocode.
.SeriesCollection(seriesNumber).AddPoint(PtNum).xvalues = x
.SeriesCollection(seriesNumber).AddPoint(PtNum).values = y
.SeriesCollection(seriesNumber).Point(PtNum).markersize = some integer
Further Details
The data I'm receiving from python follows this format, stored as a variant.
SeriesName, Point# in the series, X or O, SeriesNumber, xcoord,ycoord, instance number
O represents there needs to be a new series, X represents an already existing series
instance number is the number of times a point was repeated
Point# Is the point index of a coordinate in the series
Example lines of data
series1,1,O,1,0.25,64,1
series1,2,X,1,0.25,64,2
series2,1,O,2,0.3,90,1
Current Code
Dim pyData() As Variant
pyData = Connect_2py.recv_Data(xArgs, yArgs, seriesArgs) 'exec python script and returns data
For i = 0 To UBound(pyData) - 1
py_lineData = Split(pyData(i), ",")
createSeries = StrComp(py_lineData(2), "O", vbBinaryCompare) = 0
seriesName = py_lineData(0)
seriesNumber = CInt(py_lineData(3))
If createSeries Then
.SeriesCollection.NewSeries
.SeriesCollection(seriesNumber).Name = seriesName
Debug.Print ("Hooray new series has been made")
End If
'ENTER CODE HERE TO ADD EACH DATAPOINT TO A SPECIFIED SERIES
Next
OK so it does seem to be do-able. I was surprised that extending a series' point arrays didn't lose the existing marker properties.
Sub Tester()
Const N = 10
Dim i As Long, x(), y(), sz(), cht As Chart, ser As Series
ReDim x(1 To N)
ReDim y(1 To N)
ReDim sz(1 To N)
'create some initial data
For i = 1 To 10
x(i) = i
y(i) = i ^ 1.5
sz(i) = 2 + (Rnd() * 10)
Next i
'create a series, populate with the initial data
' and set some marker sizes
Set cht = ActiveSheet.ChartObjects(1).Chart
Set ser = cht.SeriesCollection.NewSeries()
With ser
.XValues = x
.Values = y
For i = 1 To 10
.Points(i).MarkerSize = sz(i)
Next i
End With
'extend that series one point at a time
For i = 1 To 5
ExtendSeries ser, i * 10, i * 10, i * 5
Next i
End Sub
'Extend the data in a series by adding a new X/Y pair
'Also shows how to configure (eg) the added point size
Sub ExtendSeries(ser As Series, xVal, yVal, sz)
Dim x, y, newlen As Long
With ser
x = .XValues
y = .Values
newlen = UBound(x) + 1
ReDim Preserve x(newlen)
x(newlen) = xVal
ReDim Preserve y(UBound(x) + 1)
y(newlen) = yVal
.XValues = x
.Values = y
'.Points(newlen).MarkerSize = sz 'edit: for some reason this doesn't work...
.Points(.Points.Count).MarkerSize = sz '...but this does
End With
End Sub

Set cell size equal to picture size

I'm trying to import a picture to excel cell and I'm facing issues with re-sizing.
Steps:
Copy/Paste the picture to the cell
Re-size the picture manually
And also resize the cell to fix on the picture.
Is there any other way to do it instead of manually?
I'm not sure what exactly you meant with re size the picture manually, but might this be working for you?
Sub ResizeCells()
Dim X As Double, Y As Double, Z As Double
Dim s As Shape
For Each s In ActiveSheet.Shapes
If s.Type = msoPicture Then
For X = s.TopLeftCell.Column To s.BottomRightCell.Column
Y = Y + ActiveSheet.Cells(1, X).ColumnWidth
Next X
For X = s.TopLeftCell.Row To s.BottomRightCell.Row
Z = Z + ActiveSheet.Cells(1, X).RowHeight
Next X
s.TopLeftCell.ColumnWidth = Y
s.TopLeftCell.RowHeight = Z
End If
Next s
End Sub
Note:
Max RowHeight is 409
Max ColumnWidth is 255
This goes the other way.
We will insert a Shape from the Internet.
We will move it to cell B1.
We will resize the Shape (both height and width) to fit in B1First place this link in cell A1:
http://www.dogbreedinfo.com/images26/PugPurebredDogFawnBlackMax8YearsOld1.jpg
Then run:
Sub MAIN()
Call InstallPicture
Call PlaceAndSizeShape
End Sub
Sub InstallPicture()
Dim v As String
v = Cells(1, 1).Value
With ActiveSheet.Pictures
.Insert (v)
End With
End Sub
Sub PlaceAndSizeShape()
Dim s As Shape, B1 As Range, w As Double, h As Double
Set s = ActiveSheet.Shapes(1)
s.Select
Selection.ShapeRange.LockAspectRatio = msoFalse
Set B1 = Range("B1")
s.Top = B1.Top
s.Left = B1.Left
s.Height = B1.Height
s.Width = B1.Width
End Sub
This post is old, but nobody mentioned resizing the picture to match the cell.
Excel is very unreliable when I tired to scale the width using #Andrew's code. Luckily, rCell.Left is in the correct units. You can get the actual column width using:
rCell.Offset(0, 1).Left - rCell.Left
This Code will Resize the Cell to Your Picture
Sub ResizePictureCells()
For Each Picture In ActiveSheet.DrawingObjects
PictureTop = Picture.Top
PictureLeft = Picture.Left
PictureHeight = Picture.Height
PictureWidth = Picture.Width
For N = 2 To 256
If Columns(N).Left > PictureLeft Then
PictureColumn = N - 1
Exit For
End If
Next N
For N = 2 To 65536
If Rows(N).Top > PictureTop Then
PictureRow = N - 1
Exit For
End If
Next N
Rows(PictureRow).RowHeight = PictureHeight
Columns(PictureColumn).ColumnWidth = PictureWidth * (54.29 / 288)
Picture.Top = Cells(PictureRow, PictureColumn).Top
Picture.Left = Cells(PictureRow, PictureColumn).Left
Next Picture
End Sub

Drawing a chart with owc chartspace in userform vba excel

I have a little problem with my owc chartspace, I would like to draw a chart like in the picture but my problem is that it draws only for one series I would like to draw it for the 1 the 2 and the 3 I don't know how to do this.
I have a listbox and a combobox, I select from the list box the 1,2,3 and I select from the combobx y or z such that x is fixed.
Then I put the data in plage(1) for x and plage(2) for y but the problem is that it works only for the first item I select from the listbox ( in this picture the "1" )
Could you tell what is wrong in my code?
the vba code for drawing the chart into the userform is:
Private Sub drow()
Dim i, k As Integer, x As Integer
Dim j As Integer
Dim Table(), Plage(2)
Dim id As Integer
id = 1
Do While ComboBox.Value <> idi(id, 1)
id = id + 1
Loop
For i = Cht.SeriesCollection.Count To 1 Step -1
Cht.SeriesCollection.Delete i - 1
Next i
k = 1
ReDim Table(ListBox.ListCount)
For i = 0 To ListBox.ListCount - 1
If ListBox.Selected(i) = True Then
Table(k) = ListBox.List(i)
k = k + 1
End If
Next i
With Cht
.HasLegend = True
.Legend.Position = chLegendPositionBottom
.HasTitle = True
.Title.Caption = ComboBox.Text
End With
Cht.Type = C.chChartTypeColumnClustered3D
With Cht
'first serie
.SeriesCollection.Add
.SeriesCollection(0).Caption = sheet.Cells(2, 15 + id)
.SeriesCollection(0).DataLabelsCollection.Add
.SeriesCollection(0).DataLabelsCollection(0).Position = chLabelPositionCenter
.SeriesCollection(0).DataLabelsCollection(0).Font.Color = RGB(255, 255, 255)
.SeriesCollection.Add
.SeriesCollection(1).Caption = sheet.Cells(2, 20) .SeriesCollection(1).DataLabelsCollection.Add
.SeriesCollection(1).DataLabelsCollection(0).Position = chLabelPositionCenter
.SeriesCollection(1).DataLabelsCollection(0).Font.Color = RGB(255, 255, 255)
.SetData C1.chDimCategories, C1.chDataLiteral, Table
End With
For j = 0 To ListBox.ListCount - 1
If ListBox.Selected(j) = True Then
Plage(1) = sheet.Cells(j + 3, 15 + id) 'the Xs
Plage(2) = sheet.Cells(j + 3, 20) 'Les 'the Ys
With Cht
.SeriesCollection(0).SetData C1.chDimValues, C1.chDataLiteral, Plage(1)
.SeriesCollection(1).SetData C1.chDimValues, C1.chDataLiteral, Plage(2)
End With
Erase Plage
End If
Next j
End Sub
I am very new to the whole owc and VB thing and I am having some troubles myself, but have you tried using C1.chDimXValues and C1.chDimYValues instead of the chDimValues in the below statement:
.SeriesCollection(0).SetData
C1.chDimValues, C1.chDataLiteral,
Plage(1) .SeriesCollection(1).SetData
C1.chDimValues, C1.chDataLiteral,
Plage(2)
Sorry if this might sound trivial, I can see your coding skills are much more advanced than mine. Good luck!

Resources