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:
Related
I am relatively new to Excel VBA and I am trying to learn how to plot charts with VBA script. I have the following data table (Figure1):
From this data table I would like to plot a graph (Figure2) as follows. I have plotted the chart with Excel's inbuilt function using line with markers chart type:
I have written a simple code in VBA to plot a similar type of chart, but with arrays instead of directly selecting the range from the sheet. My VBA code is as follows:
Sub plot_test2()
Dim ws2 As Worksheet
Dim i, j, c, m, n, a, lrow As Long
Dim frist_code, frist_value, frist_name As Variant
Dim xychart As Chart
Set ws2 = Worksheets("Sheet2")
i = 1: j = 1: a = 1
c = 4: lrow = 6: m = 2: n = 1
ReDim frist_code(i To lrow - 1, j To c)
ReDim frist_value(i To lrow - 1, j To c)
ReDim frist_name(i To lrow - 1, j To c)
For i = 1 To lrow - 1
For j = 1 To c
frist_value(i, j) = ws2.Cells(m, n)
frist_code(i, j) = j
frist_name(i, j) = ws2.Cells(1, n)
n = n + 1
Next j
n = 1
m = m + 1
Next i
Set xychart = ws2.Shapes.AddChart2(332, xlXYScatter, Left:=0, Top:=0, Width:=400, Height:=300).Chart
For i = 1 To lrow - 1
For j = 1 To c
xychart.SeriesCollection.NewSeries
With xychart.SeriesCollection(a)
.name = frist_name(i, j) 'series names are assigned by frist_name array
.Values = frist_value(i, j) 'series values are assigned by frist_value array
.XValues = frist_code(i, j) 'series XValues are assigned by frist_code array
.MarkerSize = 15
End With
a = a + 1
Next j
j = 1
Next i
xychart.Axes(xlCategory).TickLabelPosition = xlLow
End Sub
When I run my macro, I get the following plot (Figure3):
I wish to rename the horizontal axis labels to A, B, C, D (just like figure 2) instead of 1,2,3,4 using in the VBA macro using arrays. I have been trying to solve this problem, but I could not find the right solutions elsewhere.
I have also tried to plot the chart using xlLineMarkers instead of xlXYScatter Chart type. But the points were plotted on the same line.
I have also tried to use xychart.Axes(xlCategory).CategoryNames = Array ("A", "B", "C", "D"). But there is a compilation error.
Please let me know if anyone is able to figure out the solution or mistake is my VBA code. Thanks a ton!
To use text labels, it can't be an XY scatter chart.
What you have is line chart type data. You need to plot as a line chart, plotted by row, lines with markers, then hide the lines. Also I made the markers larger since that's how it looked in your chart.
This is a quickie I recorded and modified:
Sub Macro1()
ActiveSheet.Shapes.AddChart2(332, xlLineMarkers).Select
ActiveChart.SetSourceData Source:=Range("Sheet1!$A$1:$D$6"), PlotBy:=xlRows
Dim srs As Series
For Each srs In ActiveChart.SeriesCollection
srs.Format.Line.Visible = msoFalse
srs.MarkerSize = 8
Next
End Sub
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
Objective: I'm looking to find the reference row number of data points from filtered series that have been scatter plotted from two separate sheets.
I'm following these guides, with little success:
Excel VBA loop through visible filtered rows
Excel vba - find row number where colum data (multiple clauses)
Scenario: I have two Sheets containing data in identical tabulated format:
+-----+-------------+---------+---------+-------+
| Row | Description | X-value | Y-value | Score |
+-----+-------------+---------+---------+-------+
| 1 | "Something" | 3.4 | 4.5 | 7.0 |
| 2 | "Something" | 2.3 | 2.4 | 5.6 |
| ... | ... | ... | ... | ... |
| 100 | "Something" | 6.5 | 4.2 | 8.0 |
+-----+-------------+---------+---------+-------+
x-val and y-val from each sheet has been scatter plotted as separate series on the same chart.
I have a VBA script that on mouse hover on the chart returns the series index, x, and y coordinates of the specific data point (Arg1, ser.Values, ser.XValues):
Private Sub Chart_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal x As Long, ByVal y As Long)
Dim ElementID As Long
Dim Arg1 As Long
Dim Arg2 As Long
Dim chart_data As Variant
Dim chart_label As Variant
Dim last_point As Long
Dim chrt As Chart
Dim ser As Series
Dim score As Double
Dim desc As String
On Error Resume Next
Me.GetChartElement x, y, ElementID, Arg1, Arg2
Application.ScreenUpdating = False
Set chrt = ActiveChart
Set ser = ActiveChart.SeriesCollection(Arg1)
'x and y values
chart_data = ser.Values
chart_label = ser.XValues
If the list is unfiltered it seems the series' point index matches the row number so I can get a reference to the row and extract info quite easily:
If Arg1 = 1 Then
score = Sheet1.Cells(Arg2 + 1, "E").Value
desc = Sheet1.Cells(Arg2 + 1, "B").Value
End If
If Arg1 = 2 Then
score = Sheet2.Cells(Arg2 + 1, "E").Value
desc = Sheet2.Cells(Arg2 + 1, "B").Value
End If
Complexity: Each sheet filters on score and dynamically update the chart, so the resulting row numbers in each sheet may not contiguous. Some rows are hidden.
The above indices no longer match the correct row, so my code returns the wrong information.
Eg. Scores > 6
+-----+-------------+---------+---------+-------+
| Row | Description | X-value | Y-value | Score |
+-----+-------------+---------+---------+-------+
| 1 | "Something" | 3.4 | 4.5 | 7.0 |
| 100 | "Something" | 6.5 | 4.2 | 8.0 |
+-----+-------------+---------+---------+-------+
Outcome: I would like to use the x, y values to search the visible list on each sheet and retrieve the row number. So that I can then retrieve the description and score to pipe into my mouse-over pop-up message.
I'm a novice in VBA and guidance is appreciated.
Update 1: Showing code to do mouse-hover and adopting DisplayName's answer. It does not work for all data points, and displays a blank box. Currently trying to debug. When comparing to my original code with no filtering on rows.
Clarification: X values (and Y) could be the same. Where there are duplicate X and Y returning the first match would be ok.
Set txtbox = ActiveSheet.Shapes("hover")
If ElementID = xlSeries And Arg1 <= 2 Then
' Original code that only works on un-filtered rows in Sheet 1 & 2
' If Arg1 = 1 Then
' score = Sheet1.Cells(Arg2 + 1, "E").Value
' desc = Sheet1.Cells(Arg2 + 1, "B").Value
' ElseIf Arg1 = 2 Then
' score = Sheet2.Cells(Arg2 + 1, "E").Value
' desc = Sheet2.Cells(Arg2 + 1, "B").Value
' End If
' Code from DisplayName
With Worksheets(Choose(Arg1, Sheet1.Name, Sheet2.Name)) ' reference Sheet1 if Arg1=1 and Sheet2 if Arg1=2
With .Range("C2", .Cells(.Rows.Count, "C").End(xlUp)).Find(what:=chart_label(Arg2), LookIn:=xlValues, lookat:=xlWhole) ' search reference referenced sheet x-values range for current x-value
If .Offset(, 1).Value = chart_data(Arg2) Then 'check y-value
score = .Offset(, 2).Value ' assign 'score' the value of found cell offset two columns to the right
desc = .Offset(, -1).Value ' assign 'desc' the value of found cell offset one column to the left
End If
End With
End With
If Err.Number Then
Set txtbox = ActiveSheet.Shapes.AddTextbox _
(msoTextOrientationHorizontal, x - 150, y - 150, 300, 50)
txtbox.Name = "hover"
txtbox.Fill.Solid
txtbox.Fill.ForeColor.SchemeColor = 9
txtbox.Line.DashStyle = msoLineSolid
chrt.Shapes("hover").TextFrame.Characters.Text = "Y: " & Application.WorksheetFunction.Text(chart_data(Arg2), "?.?") & _
", X: " & Application.WorksheetFunction.Text(chart_label(Arg2), "?.?") & _
", Score: " & Application.WorksheetFunction.Text(score, "?.?") & ", " & desc
With chrt.Shapes("hover").TextFrame.Characters.Font
.Name = "Arial"
.Size = 12
.ColorIndex = 16
End With
last_point = Arg2
End If
txtbox.Left = x - 150
txtbox.Top = y - 150
Else
txtbox.Delete
End If
Application.ScreenUpdating = True
End Sub
Update 2: As Tim Williams noted there is no way to get around this without looping through the range. I combined his pseudocode with DisplayName's example to get the desired behavior where x, y is compared to get the score and description. Here is the code that worked:
With Worksheets(Choose(Arg1, Sheet1.Name, Sheet2.Name))
For Each row In .Range("C2", .Cells(.Rows.Count, "C").End(xlUp)).SpecialCells(xlCellTypeVisible)
If row.Value = chart_label(Arg2) And row.Offset(, 1).Value = chart_data(Arg2) Then
score = row.Offset(, 2).Value
desc = row.Offset(, -1).Value
Exit For
End If
Next row
End With
I wish I could split the bounty between Tim Williams and Display Name. As I can only choose one the award goes to Tim.
You can do something like this:
'called from your event class using Arg1 and Arg2
Sub HandlePointClicked(seriesNum As Long, pointNum As Long)
Dim vis As Range, c As Range, i As Long, rowNum As Long
Dim sht As Worksheet
' which sheet has the source data?
Set sht = GetSheetFromSeriesNumber(seriesMum)
'Get only the visible rows on the source data sheet
' (adjust to suit your specific case...)
Set vis = sht.Range("A2:A100").SpecialCells(xlCellTypeVisible)
'You can't index directly into vis
' eg. vis.Cells(pointNum) may not work as you might expect
' so you have (?) to do something like this loop
For Each c In vis.Cells
i = i + 1
If i = pointNum Then rowNum = c.Row
Next c
Debug.Print rowNum '<< row number for the activated point
End Sub
As reparation of my earlier attempt to answer without going into details of your question and to prevent my deleted answer to be viewed by experts, I am offering another solution. But before going into codes and all, I must acknowledge that the best solution is already provided by #Tim Williams and think only his answer is worthy to be accepted (till date). I found no other option to get row numbers without looping.
I only attempting to put the pieces together and integrating with your code. I have taken following liberties
Used class module as directly coding Chart_MouseMove may become troublesome while modifying/working with chart.
Chart is placed on the worksheet only
Used a stationary Textbox already placed on the chart to avoid deleting & recreating the same. It may cause problem in run time error
Avoided disabling Screen update and Error bypass.
You may please modify the code according to your requirement.
Now first insert a class module named CEvent. In the class module add
Public WithEvents Scatter As Chart
Private Sub Scatter_MouseMove(ByVal Button As Long, ByVal Shift As Long, ByVal X As Long, ByVal Y As Long)
Dim ElementID As Long
Dim Arg1 As Long
Dim Arg2 As Long
Dim chart_data As Variant
Dim chart_label As Variant
Dim last_point As Long
Dim chrt As Chart
Dim Ser As Series
Dim score As Double
Dim desc As String
Dim VRng, Cl As Range, SerStr As String, part As Variant, Txt As Shape
'On Error Resume Next
Set chrt = ActiveChart
chrt.GetChartElement X, Y, ElementID, Arg1, Arg2
'Application.ScreenUpdating = False
'x and y values
If ElementID = xlSeries And Arg1 <= 2 Then
Set Ser = ActiveChart.SeriesCollection(Arg1)
SerStr = Ser.Formula
part = Split(SerStr, ",")
Set VRng = Range(part(1)).SpecialCells(xlCellTypeVisible)
Vrw = 0
For Each Cl In VRng.Cells
Vrw = Vrw + 1
If Vrw = Arg2 Then
Exit For
End If
Next
score = Cl.Offset(, 2).Value
desc = Cl.Offset(, -1).Value
chart_data = Cl.Value
chart_label = Cl.Offset(, 1).Value
Set Txt = ActiveSheet.Shapes("TextBox 2")
'Txt.Name = "hover"
Txt.Fill.Solid
Txt.Fill.ForeColor.SchemeColor = 9
Txt.Line.DashStyle = msoLineSolid
Txt.TextFrame.Characters.Text = "Y: " & chart_label & ", X: " & chart_data & ", Score: " & score & ", " & vbCrLf & desc
With Txt.TextFrame.Characters.Font
.Name = "Arial"
.Size = 12
.ColorIndex = 16
End With
last_point = Arg2
'Txtbox.Left = X - 150
'Txtbox.Top = Y - 150
Else
'Txt.Visible = msoFalse
End If
'Application.ScreenUpdating = True
End Sub
Then in a standard module
Dim XCEvent As New CEvent
Sub InitializeChart()
Set XCEvent.Scatter = Worksheets(1).ChartObjects(1).Chart
Worksheets(1).Range("I25").Value = "Scatter Scan Mode On"
Worksheets(1).ChartObjects("Chart 1").Activate
End Sub
Sub ReleaseChart()
Set XCEvent.Scatter = Nothing
Worksheets(1).Range("I25").Value = "Scatter Scan Mode Off"
End Sub
The sub InitializeChart() & ReleaseChart() may be assigned to buttons placed on the worksheet near the chart. May please modify Sheet names, addresses, Chart name, Textbox names etc suitably. It is working with make shift filtered data
Hope It will be useful
you have to find the cell with the current x-value and then offset from it
so substitute:
If Arg1 = 1 Then
score = Sheet1.Cells(Arg2 + 1, "E").Value
desc = Sheet1.Cells(Arg2 + 1, "B").Value
End If
If Arg1 = 2 Then
score = Sheet2.Cells(Arg2 + 1, "E").Value
desc = Sheet2.Cells(Arg2 + 1, "B").Value
End If
with:
With Worksheets(Choose(Arg1, Sheet1.Name, Sheet2.Name)) ' reference Sheet1 if Arg1=1 and Sheet2 if Arg1=2
With .Range("C2", .Cells(.Rows.Count, "C").End(xlUp)).Find(what:=chart_label(Arg2), LookIn:=xlValues, lookat:=xlWhole) ' search reference referenced sheet x-values range for current x-value
score = .Offset(, 2).Value ' assign 'score' the value of found cell offset two columns to the right
desc = .Offset(, -1).Value ' assign 'desc' the value of found cell offset one column to the left
End With
End With
I get error when I try to assign TextBox1 to variable X.
Sub TB1()
Dim X As TextBox
Dim Y As String
X = TextBox1
If Len(X) < 4 Then
Y = X
Do
Y = "0" & Y
Loop Until Len(Y) >= 4
X = Y
End If
End Sub
You've got a few issues. See comments for details in the code
Sub TB1()
Dim X As TextBox
Dim Y As String
Set X = Me.TextBoxes("Textbox 1")
'You need to have some sort of reference to get to the textbox.
'Me in this case is a worksheet object I tested in the Sheet1 module.
'It has a collection of textboxes which you can refer to by name. Click on your textbox in excel to see the name in the upper left corner.
'The `Set` syntax is necessary for objects
If Len(X.Text) < 4 Then
Y = X.Text
'Have to explicitly refer to the text in the textbox since it has other properties you can change like height and width
Do
Y = "0" & Y
Loop Until Len(Y) >= 4
X.Text = Y 'Explicitly refer to the textbox text again to reassign
End If
End Sub
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.