I'm currently trying to add a data label to only the last point of each series in each graph on a worksheet. I'm currently adapting one of the solutions proposed here: "https://superuser.com/questions/1285179/adding-data-label-only-to-the-last-value".
However, my code keeps on popping up with the error: "Runtime error '13', type mismatch". When I go in debug mode, it higlights the line "Set chrt = ws.ChartObjects(Chart_Name)".
Sub LastDataLabel()
Dim Chart_Name As String
Dim i, Total_Charts, Total_Series As Integer
Dim ws As Worksheet
Dim chrt As Chart
Dim srs As Series
Dim pnt As Point
Dim p As Integer
Application.ScreenUpdating = False
Set ws = ActiveSheet
Total_Charts = Range("C12").Value
For i = 1 To Total_Charts
Chart_Name = ActiveSheet.Cells(14 + i, 2).Value 'A list of all chart names exists along this range
Set chrt = ws.ChartObjects(Chart_Name)
Total_Series = chrt.SeriesCollection.Count
For j = 1 To Total_Series
Set srs = chrt.SeriesCollection(j)
srs.ApplyDataLabels
For p = 1 To srs.Points.Count - 1
Set pnt = srs.Points(p)
pnt.DataLabel.Text = ""
Next
srs.Points(srs.Points.Count).DataLabel.Format.TextFrame2.TextRange.Font.Size = 10
srs.Points(srs.Points.Count).DataLabel.Format.TextFrame2.TextRange.Font.Name = "Arial"
Next j
Next i
End Sub
Any and all help is greatly appreciated. Thank you!
ChartObject is just a container shape for the chart - it's not the actual chart itself
This should improve things:
Set chrt = ws.ChartObjects(Chart_Name).Chart
Related
I am trying to retrieve the links in which a PowerPoint is connected to using VBA in Excel. I receive two different errors from the two different approaches in which I will attach below, both stemming from calling the Slide and Shape objects of PowerPoint. The first macro results in an "Object required" error starting with the first line of the For Loop.
Sub Macro1()
'Opening up the PowerPoint to retrieve the links
Dim PPTName As String
Dim PPTApp As Object
PPTName = Sheets("Sheet1").Range("G2").Value
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Presentations.Open PPTName
Dim i As Integer
Dim j As Long
Dim k As Long
i = 10
For j = 1 To PPT.ActivePresentation.Slides.Count
For k = 1 To PPT.ActivePresentation.Slides(i).Shapes.Count
If PPTShape.Type = msoLinkedPicture Or PPTShape.Type = msoLinkedOLEObject Then
Sheets("Sheet1").Range("G" & CStr(i)) = PPTShape.LinkFormat.SourceFullName
i = i + 1
End If
k = k + 1
Next k
j = j + 1
Next j
End Sub
The second macro results in a "Compile error" starting with the "Set PPTSlides = CreateObject("PowerPoint.Slides")."
Sub Macro2()
Dim PPTName As String
Dim PPTApp As Object
PPTName = Sheets("Sheet1").Range("G2").Value
Set PPTApp = CreateObject("PowerPoint.Application")
PPTApp.Presentations.Open PPTName
Dim PPTSlides As Object
Dim PPTShapes As Object
Set PPTSlides = CreateObject("PowerPoint.Slides")
Set PPTShapes = CreateObject("PowerPoint.Shapes")
For Each PPTSlides In PPT.ActivePresentation.Slides
For Each PPTShapes In PPT.ActivePresentation.Shapes
If PPTShape.Type = msoLinkedPicture Or PPTShape.Type = msoLinkedOLEObject Then
Sheets("Sheet1").Range("G" & CStr(i)) = PPTShape.LinkFormat.SourceFullName
i = i + 1
End If
Next PPTShapes
Next PPTSlides
End Sub
I have not used VBA in Excel to work with PowerPoint before, so this is a new learning curve for me. Because of these errors, I have not been able to check my For Loop for errors as well. Any help is appreciated on these issues. Thanks in advance!
Fortunately, that is only a minor issue: A wrong index is used:
i = 10
For j = 1 To PPT.ActivePresentation.Slides.Count
For k = 1 To PPT.ActivePresentation.Slides(i).Shapes.Count
If you look closely, then you need to use j instead of i in the last row.
And for the second code listing, there you can just omit the lines
Set PPTSlides = CreateObject("PowerPoint.Slides")
Set PPTShapes = CreateObject("PowerPoint.Shapes")
Because down below the first variable will be set from ActivePresentation.Slides.
As you are using the for each loop it also make sense to rename these two variables from plural to singular, i.e. PPTSlide instead of PPTSlides.
Please note as well that For Each PPTShapes In PPT.ActivePresentation.Shapes does not work. You need to get the Shapes from For Each PPTShape in PPTSlide.Shapes.
All the best
I am trying to make a fairly easy macro to activate the next series in an already active chart. (my main macro contains all the formatting stuff).
Problem with this coding, is that i am not able to assign the current active series (already selected in the graph in excel). In a graph with n series (SeriesCollection.Count = n) I want to go from x, to x+1 and if x=n i want to go back to series 1 (so the for/next included here is not necessary if I get the macro to work as intended).
Sub NextButton_Click()
Dim cht As Chart
Set cht = ActiveChart
If cht Is Nothing Then
MsgBox "Select a chart."
Exit Sub
End If
With cht
For SrsIndx = 1 To .SeriesCollection.Count
.SeriesCollection(SrsIndx).Select
Next SrsIndx
End With
End Sub
For Simple graphs, just use PlotOrder: If you are not using a Combo Chart (i.e. not mixing Line and Bar charts, and not using the Secondary Axis), then you can just use the following code:
IIF(TypeName(Selection)="Series", Selection.PlotOrder, -1)
This will return -1 if you do not have a Series selected.
However, this is actually the order within the ChartGroup - the conditions above were for when there is only 1 ChartGroup on the Chart.
Otherwise, try using Name and a loop:
Function ActiveSeriesNumber(ThisSeries AS Series) AS Long
Dim ThisChart AS Chart, TestNumber AS Long
ActiveSeriesNumber = -1
On Error GoTo FunctionError
Set ThisChart = ThisSeries.Parent.Parent 'Object Model Is Chart.ChartGroup.Series
For TestNumber = 1 to ThisChart.SeriesCollection.Count
If ThisChart.SeriesCollection(TestNumber).Name = ThisSeries.Name THen
ActiveSeriesNumber = TestNumber
Exit Function
End If
Next TestNumber
FunctionError:
On Error GoTo -1
End Function
Use this by calling ActiveSeriesNumber(Selection)
Here's the General Idea. Step through that code and you can see each series gets selected. You'll need add some object validation as this assumes the selected object is a Series.
Sub CycleSeries()
Dim MyObject As ChartObject
Dim MyChart As Chart
Dim SerCol As SeriesCollection
Dim SelSeries As Series
Dim indexSeries As Series
Dim ChartSheet As Worksheet
Dim x As Integer
Set ChartSheet = ThisWorkbook.Sheets(1)
Set MyObject = ChartSheet.ChartObjects(1)
Set MyChart = MyObject.Chart
Set SerCol = MyChart.SeriesCollection
Set SelSeries = Excel.Application.Selection
For x = 1 To SerCol.Count
Set indexSeries = SerCol(x)
If indexSeries.Name = SelSeries.Name Then
If (x = SerCol.Count) Then
Set SelSeries = SerCol(1)
SelSeries.Select
Exit For
Else
Set SelSeries = SerCol(x + 1)
SelSeries.Select
Exit For
End If
End If
Next x
End Sub
I have excel with data that I'm writing in word, it is open and I try to copy chart from excel to word, without linking it, so that any other user can open it without static link to original excel file.
Sub Make4Segment(Wapp As Object)
Dim Sheet As Excel.Worksheet
Dim MyChart As ChartObject
Set Sheet = Excel.ThisWorkbook.Sheets("DOC")
Set MyChart = Excel.ThisWorkbook.Sheets("DOC").ChartObjects("C1")
MyChart.Chart.ChartArea.Copy
With Wapp.Application.Selection.Range
.PasteAndFormat Type:=wdChart
End With
End sub
I'm getting error 4605 on paste line.
Change:
.PasteAndFormat Type:=wdChart
With:
.PasteSpecial Link:=False, DataType:=26
That should paste the Object correctly with Data and Without Link
You can Try with these different datatypes if this one is not what you need.
To reader in future: I was unable to find easy copy/paste solution to copy chart form excel to word. So I created this monstrosity. It creates chart in word, copies data for chart form excel file and embeds data in word file. Loads chart settings from excel files cells for ease of changing chart appearance. Resulting word document is independent and with chart data, and can be sent to anyone.
Sub GenerateReport()
Dim Wapp As Object
'Launches word application
Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Wapp.Activate
...
Call CreateChart(Wapp)
End Sub
'Procedure, that creates chart in Word
Sub CreateChart(Wapp As Object)
Dim Ch4y As Word.InlineShape
Dim EmChData As Excel.Worksheet
Dim SrDataSh As Excel.Worksheet
Dim FomtCh As Excel.ChartObject
Dim DbWidth As Double
Dim DbHeight As Double
Dim DbIndentCh As Double
Dim DbLineWeight As Double
Dim DbDegrees As Double
Dim DbChLeHeight As Double
Dim DbChLeWidth As Double
Dim DbChLeLeft As Double
Dim DbChLeTop As Double
Dim LnChType As Long
Dim LnXLabelSpace As Long
Dim LnYMayorUnit As Long
Dim LnYMinimumScale As Long
Dim LnChBorder As Long
Dim LnChFontSize As Long
Dim BoLegend As Boolean
Dim BoTitle As Boolean
Dim In1 As Integer
Dim In2 As Integer
Dim In3 As Integer
Dim In4 As Integer
Dim In5 As Integer
Dim In6 As Integer
Dim In7 As Integer
Dim In8 As Integer
Dim In9 As Integer
Dim StChFont As String
'Creates new chart in word
Set Ch4y = Wapp.ActiveDocument.InlineShapes.AddChart2
'Embed data in chart, to make it independent form excel
'Creates reference to place where data will be stored
Set EmChData = Ch4y.Chart.ChartData.Workbook.Worksheets(1)
'Creates reference to source data sheet
Set SrDataSh = Excel.ThisWorkbook.Sheets("DOC")
'Loads data from Excel sheet for customizability
DbWidth = SrDataSh.Range("A159").Value '490
DbHeight = SrDataSh.Range("A160").Value '180
DbIndentCh = SrDataSh.Range("A161").Value '0
LnChType = SrDataSh.Range("A162").Value '4
BoLegend = SrDataSh.Range("A163").Value 'True
BoTitle = SrDataSh.Range("A164").Value 'False
In1 = SrDataSh.Range("A166").Value '139
In2 = SrDataSh.Range("A167").Value '231
In3 = SrDataSh.Range("A168").Value '246
In4 = SrDataSh.Range("A170").Value '0
In5 = SrDataSh.Range("A171").Value '133
In6 = SrDataSh.Range("A172").Value '155
DbLineWeight = SrDataSh.Range("A173").Value '1.75
DbDegrees = SrDataSh.Range("A174").Value '90
LnXLabelSpace = SrDataSh.Range("A175").Value '1
LnYMayorUnit = SrDataSh.Range("A176").Value '10
LnYMinimumScale = SrDataSh.Range("A177").Value '70
LnChBorder = SrDataSh.Range("A178").Value '-4142
StChFont = SrDataSh.Range("A179").Value 'Open Sans
LnChFontSize = SrDataSh.Range("A180").Value '9
In7 = SrDataSh.Range("A182").Value '151
In8 = SrDataSh.Range("A183").Value '151
In9 = SrDataSh.Range("A184").Value '151
DbChLeHeight = SrDataSh.Range("A185").Value '18
DbChLeWidth = SrDataSh.Range("A186").Value '200
DbChLeLeft = SrDataSh.Range("A187").Value '140
DbChLeTop = SrDataSh.Range("A188").Value '155
'Clears range
EmChData.Range("A1:XFD1048576").Clear
'Copy data
EmChData.Range("A1:C49").Value = SrDataSh.Range("B109:D157").Value
'Set Source data
Ch4y.Chart.SetSourceData Source:="'Sheet1'!$A$1:$C$49", PlotBy:=xlColumns
'Create reference to excel chart
Set FomtCh = ThisWorkbook.Sheets("Doc").ChartObjects(1)
With Wapp
With .Selection
'This line change position of chart that will be created to left or to right
.ParagraphFormat.LeftIndent = DbIndentCh
End With
End With
'Creates needed formating
With Ch4y
'Set size for chart
.Width = DbWidth
.Height = DbHeight
With .Chart
'Sets chart type
.ChartType = LnChType
'Sets chart legend to visible/unvisable
.HasLegend = BoLegend
'Sets chart title visible/unvisable
.HasTitle = BoTitle
'Sets color back to original for data series lines (for some reason it is not pasted in previous line)
.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(In1, In2, In3)
.SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(In4, In5, In6)
'Sets line thicknes
.SeriesCollection(1).Format.Line.Weight = DbLineWeight
.SeriesCollection(2).Format.Line.Weight = DbLineWeight
'Works with x-axis
With .Axes(xlCategory)
'Sets orientation of x axis labels
.TickLabels.Orientation = DbDegrees
'Force to show all month under x-axis
.TickLabelSpacing = LnXLabelSpace
End With
'Works with y-axis
With .Axes(xlValue)
'Sets unit size for y-axis
.MajorUnit = LnYMayorUnit
'Sets value on y-axis from where values will start (Changes y=0 to value specified)
.MinimumScale = LnYMinimumScale
End With
With .ChartArea
'Sets border to none
.Border.LineStyle = LnChBorder
'Sets font
.Format.TextFrame2.TextRange.Font.Name = StChFont
'Sets font size
.Format.TextFrame2.TextRange.Font.Size = LnChFontSize
'Sets chart font color
.Font.Color = RGB(In7, In8, In9)
End With
'Checks if Legend for chart is enabled
If .HasLegend = True Then
With .Legend
'Sets height of legend
.Height = DbChLeHeight
'Sets width of legend
.Width = DbChLeWidth
'Sets distance from left side of chart
.Left = DbChLeLeft
'Sets distance from top side of chart
.Top = DbChLeTop
End With
End If
End With
End With
End Sub
My code is working fine but it ends up giving me a runtime error "object required.
I am not able to find out what is causing this error. This code is related to deleting graphs that don't have any data in them .
Sub HideEmptyCharts()
Dim wksCharts As Worksheet
Dim objCO As ChartObject
' Set up a variable for the worksheet containing the charts
Set wksCharts = ThisWorkbook.Sheets("Report output")
' Loop through every embedded chart object on the worksheet
For Each objCO In wksCharts.ChartObjects
' Make each one visible
objCO.Visible = True
' If the chart is empty make it not visible
If IsChartEmpty(objCO.Chart) Then objCO.Visible = False
Next objCO
End Sub
Private Function IsChartEmpty(chtAnalyse As Chart) As Boolean
Dim i As Integer
Dim j As Integer
Dim objSeries As Series
' Loop through all series of data within the chart
For i = 1 To chtAnalyse.SeriesCollection.Count
Set objSeries = chtAnalyse.SeriesCollection(i)
' Loop through each value of the series
For j = 1 To UBound(objSeries.Values)
' If we have a non-zero value then the chart is not deemed to be empty
If objSeries.Values(j) <> 0 Then
' Set return value and quit function
IsChartEmpty = False
Exit Function
End If
Next j
Next i
IsChartEmpty = True
End Function
Change the object passed to the function from Chart to full ChartObjectlike this:
Private Sub HideEmptyCharts()
Dim wksCharts As Worksheet
Dim objCO As ChartObject
Set wksCharts= ThisWorkbook.Sheets("Report output")
For Each objCO In wksCharts.ChartObjects
objCO.Visible = True
If IsChartEmpty(objCO) Then objCO.Visible = False
Next objCO
End Sub
Private Function IsChartEmpty(co As ChartObject) As Boolean
Dim i As Integer
Dim j As Integer
Dim objSeries As Series
For i = 1 To co.Chart.SeriesCollection.Count
Set objSeries = co.Chart.SeriesCollection(i)
For j = 1 To UBound(objSeries.Values)
If objSeries.Values(j) <> 0 Then
IsChartEmpty = False
Exit Function
End If
Next j
Next i
IsChartEmpty = True
End Function
An outdated pivotcache and some still remembered but in the meantime missed items caused some trouble to me in the past. So I propose to add this code once before:
Dim pc As PivotCache
For Each pc In ThisWorkbook.PivotCaches
pc.MissingItemsLimit = xlMissingItemsNone
pc.Refresh
Next pc
I am having two charts in an excel sheet ("DesiredData"), and my purpose is to determine the chart having a greater value of Maximum Scale on Y-axis and then changing the value of Maximum Scale in the other chart. My code is :
Sub reArrange()
With ThisWorkbook.Sheets("DesiredData")
Dim maxScale1 As Long
Dim maxScale2 As Long
.ChartObjects(1).Activate
'runtime error at this line
ActiveChart.Axes(xlValue, xlPrimary).Activate
maxScale1 = .ChartObjects(1).Axes(xlValue, xlPrimary).MaximumScale
.ChartObjects(2).Activate
ActiveChart.Axes(xlValue, xlPrimary).Activate
maxScale2 = .ChartObjects(2).Axes(xlValue).MaximumScale
If maxScale1 > maxScale2 Then
.ChartObjects(2).Activate
.ChartObjects(2).Axes(xlValue).MaximumScale = maxScale1
Else
.ChartObjects(1).Activate
.ChartObjects(1).Axes(xlValue).MaximumScale = maxScale2
End If
End With
End Sub
It is giving Run-Time error the specified line, please help me out.
something like this
Dim c As ChartObject
Dim c2 As ChartObject
Dim a1 As Axis
Dim a2 As Axis
Set c = Worksheets("Sheet1").ChartObjects(1)
Set c2 = Worksheets("Sheet1").ChartObjects(2)
Dim x As Chart
Set x = c.Chart
Set a1 = x.Axes(XlAxisType.xlValue, xlPrimary)
Set x = c2.Chart
Set a2 = x.Axes(XlAxisType.xlValue, xlPrimary)
a1.MaximumScale = a2.MaximumScale
Your code almost works, if you remove some unnecessary .Activate commands. First of all, you can't activate an axis, only select it. Second of all, there's no need to select an axis or activate a chart to do what you want. You do need to insert .Chart between .ChartObjects(i) and .Axes(xlValue).
The following ought to work as expected:
Sub reArrange()
Dim maxScale1 As Long
Dim maxScale2 As Long
With ThisWorkbook.Sheets("DesiredData")
maxScale1 = .ChartObjects(1).Chart.Axes(xlValue, xlPrimary).MaximumScale
maxScale2 = .ChartObjects(2).Chart.Axes(xlValue).MaximumScale
If maxScale1 > maxScale2 Then
.ChartObjects(2).Chart.Axes(xlValue).MaximumScale = maxScale1
Else
.ChartObjects(1).Chart.Axes(xlValue).MaximumScale = maxScale2
End If
End With
End Sub