I have a chart embedded on a sheet (X, Y scatter). I also have a mouseover event on the chart which - when you hover over a datapoint - prints the selected value of the corresponding datapoint to a cell. This works with using the .GetChartElement method.
However, I'd also like to add a feature with you can add an arrow (or line) connecting a datapoint and a predefined, named cell. I also managed to do this but unfortunately my calculations aren't accurate enough because the datapoint end of the line is never at the point exactly but somewhere around it (See picture).
The way I did this:
Private Sub myChartClass_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Me.myChartClass.GetChartElement X, Y, ElementID, Arg1, Arg2
Set chrt = ActiveSheet.ChartObjects(1).Chart
Set ser = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1)
chart_data = ser.Values
chart_label = ser.XValues
YValue = chart_data(Arg2)
XValue = chart_label(Arg2)
'[Code to print corresponding values]
If addComment = True Then Call wks35.addComment(XValue, YValue)
This way I can either pass the coordinates (X, Y variables) and the actual values on the axes (XValue, YValue). Above, the latter is used.
Public Sub addComment( _
ByVal X As Double, _
ByVal Y As Double _
)
Dim chartObj As Chart
Dim chartWidth As Double
Dim chartHeight As Double
Dim l1 As Long, l2 As Long, r1 As Long, r2 As Long
With wks35
Set chartObj = .ChartObjects(1).Chart
chartWidth = chartObj.PlotArea.Width
chartHeight = chartObj.PlotArea.Height
Y = chartHeight - (chartHeight * ((Y - chartObj.Axes(xlValue).MinimumScale) _
/(chartObj.Axes(xlValue).MaximumScale - chartObj.Axes(xlValue).MinimumScale)))
X = chartWidth * ((X - chartObj.Axes(xlCategory).MinimumScale) / _
(chartObj.Axes(xlCategory).MaximumScale - chartObj.Axes(xlCategory).MinimumScale))
l1 = Range("Comment1").Left
l2 = Range("Comment1").Top
r1 = X + ActiveSheet.ChartObjects(1).Left + chartObj.PlotArea.InsideLeft
r2 = Y + ActiveSheet.ChartObjects(1).Top + chartObj.PlotArea.InsideTop
With ActiveSheet.Shapes.AddLine(l1, l2, r1, r2).Line
.ForeColor.RGB = RGB(255, 0, 0)
End With
End With
End Sub
So basically the idea was to have the values on the axes and by calculating its relative position considering the minimum and maximum values on the axis get the datapoint's absolute top and left value from the borders of the plotarea. Then adding the difference of the chart and the plotarea and then the charts top and left.
It may be long and difficult to follow, but I appreciate any help.
Whatever, I figured it out.
I used this
chartWidth = chartObj.PlotArea.InsideWidth
chartHeight = chartObj.PlotArea.InsideHeight
instead of this
chartWidth = chartObj.PlotArea.Width
chartHeight = chartObj.PlotArea.Height
It was almost there so I added some constants to the end (10 to left, 3 to top) the lines are at their place.
Related
I was trying to make sense of ByVal and ByRef and passing arguments from long to double using the ByVal keyword.
I noticed that VBA gave me the incorrect answer for the value of y squared. It does work when y (i in my sub) is a whole number.
In the below example I had i = 22.5.
The spreadsheet gave me 506.25.
My function gave me 484.
I thought both long and double support decimals.
Sub automation_test()
Dim i As Long
Dim j As Long
Dim x As Long
Dim ans As Long
i = Range("B1")
j = Range("B2")
x = Range("B3")
ans = my_model(i, j, x)
Range("B4").Value = ans
End Sub
Function my_model(ByVal y As Double, ByVal m As Double, ByVal q As Double) As Double
' my_model = (y ^ 2) * (m ^ 3) * (q ^ 1 / 2)
my_model = y ^ 2
End Function
You must declare all used variables As Double (or As Single, depending on the maximum value to be used).
Long variables do not accept decimals.
The difference is exactly the one coming from rounding (down):
22.5^2 = 506.25
22^2 = 484
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
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
This is kind of a follow-up to my previous question here, but different enough I felt that asking a new question would be best. I have used a series of window handles to lock a userform to the Excel spreadsheet, which causes the 0,0 position to be the top left of the column and row headers (or the "select all" button). The tl;dr of this is that I'm trying to find how to determine the height of the column headers, and the width of the row headers, so that I can position a userform correctly on a page regardless of the user's default excel font settings.
I don't think the code that I have so far for my userform will be helpful, but I'm happy to post it if anyone would like to see. I can remove the headings altogether by setting the DisplayHeadings property to false, but this doesn't really work for my end goal.
It does seem like the height of the column header would be equal to the default height of a cell with the same font type and size. I haven't tested this method since it would only give me half of what I need, but I would still like to confirm if this is accurate.
I also know that the width of the row header will change the further you go down on the spreadsheet (eg. first increasing at 1,000, and then 10,000, 100,000, and 1,000,000). I only need to find the smallest width (everything less than 1,000), but I would like to know how to find a larger width if it's not too complicated.
To locate the header size, I have tried comparing a cell's .left and .top properties after removing the display headings through the following code:
Sub TestHeadings()
Dim fl, ft, tl, tt As Integer
tl = Application.ActiveSheet.Range("A1").Left
tt = Application.ActiveSheet.Range("A1").Top
Application.ActiveWindow.DisplayHeadings = False
fl = Application.ActiveSheet.Range("A1").Left
ft = Application.ActiveSheet.Range("A1").Top
Debug.Print "True: " & tl & ", " & tt
'Returns True: 0, 0
Debug.Print "False: " & fl & ", " & ft
'Returns False: 0, 0
End Sub
I have also tried comparing a userform's (called Working_Menu, the .StartUpPosition property is set to 0-Manul) .left and .top properties after disabling the display headings, through the following code:
Sub TestHeadings()
Dim fl, ft, tl, tt As Integer
Application.ActiveWindow.DisplayHeadings = False
With Working_Menu
.Left = 5 'Also tried 0
.Top = 5 'Also tried 0
.Show
End With
fl = Working_Menu.Left
ft = Working_Menu.Top
Application.ActiveWindow.DisplayHeadings = True
tl = Working_Menu.Left
tt = Working_Menu.Top
Debug.Print "True: " & tl & ", " & tt
'Returns True: 5, 145, or 0, 140
Debug.Print "False: " & fl & ", " & ft
'Returns False: 5, 144.75, or 0, 139.5 (Adjusted for screen resolution)
End Sub
My results are commented in the code, but neither approach returned any differences indicating a header size. Does anyone have any idea how I can determine the height of the column header, or the width of the row header?
Thanks!
This Sub will return its parameters HeightPoints (column header height in points) and WidthPoints (row header width in points):
Sub HeadingsSize(ByRef HeightPoints As Single, ByRef WidthPoints As Single)
Dim rC As Range, bSU As Boolean
Dim x1 As Long, x2 As Long, y1 As Long, y2 As Long
Const PxToPt As Single = 72 / 96
bSU = Application.ScreenUpdating
If bSU Then Application.ScreenUpdating = False
With ActiveWindow
Set rC = .VisibleRange.Cells(1)
y1 = .PointsToScreenPixelsY(rC.Top)
x1 = .PointsToScreenPixelsX(rC.Left)
.DisplayHeadings = Not .DisplayHeadings
y2 = .PointsToScreenPixelsY(rC.Top)
x2 = .PointsToScreenPixelsX(rC.Left)
.DisplayHeadings = Not .DisplayHeadings
End With
HeightPoints = Abs(y2 - y1) * PxToPt
WidthPoints = Abs(x2 - x1) * PxToPt
Application.ScreenUpdating = bSU
End Sub
I am trying to add data label only to the largest piece of a pie chart using VBA.
When I try to run the following code i get an error message:
'Object doesnt support this property of method'
The error referes to the line:
sem = ActiveSheet.ChartObjects("REJT").Chart.SeriesCollection(1).Points(x).Value
Can anyone tell me what is the issue with this line?
Is there an alternative way of getting value of a chart data point?
Dim krb As Long
Dim x As Long
Dim rr As Long
Dim sem As Long
Dim xmax As Long
Set pts = ActiveSheet.ChartObjects("REJT").Chart.SeriesCollection(1).Points
krb = pts.Count
x = 1
rr = 0
'While loop to find largest part of pie chart
While x < (krb + 1)
sem = ActiveSheet.ChartObjects("REJT").Chart.SeriesCollection(1).Points(x).Value
MsgBox (sem)
If sem > rr Then
rr = sem
xmax = x
End If
x = x + 1
Wend
'Add data label to the largest part of pie chart
ActiveSheet.ChartObjects("REJT").Activate
ActiveChart.SeriesCollection(1).Select
ActiveChart.SeriesCollection(1).Points(xmax).Select
ActiveChart.SeriesCollection(1).Points(xmax).ApplyDataLabels
Here is one way to get the maximum point value from your pie chart and apply data label to its position:
Sub pieChartMaxDataLabel()
Dim cht As Chart
Set cht = ActiveChart
maxValue = WorksheetFunction.Max(cht.SeriesCollection(1).Values)
maxPosition = WorksheetFunction.Match(maxValue, cht.SeriesCollection(1).Values, 0)
cht.SeriesCollection(1).Points(maxPosition).ApplyDataLabels
Debug.Print "Max Value is: "; maxValue; " At Position: "; maxPosition
End Sub
Tested with chart values that look like this:
Results: