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
Related
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 am very new to VBA, having started programming it yesterday. I am writing a data processing program which requires keeping track of two cells, one on each spreadsheet. The code which reproduces the errors I am experiencing is below. When I call the sub moveCell() in sub Processor(), nothing happens to DIRow and DIColumn, and the code spits out error 1004 at the line indicated. I have tried using DICell = DICell.Offset(), but it returns the same error.
How can I redefine a Range variable to be a different cell?
'<<Main Processor Code>>'
Sub Processor()
Dim PDRow As Integer
Dim PDColumn As Integer
Dim DIRow As Integer
Dim DIColumn As Integer
PDRow = 1
PDColumn = 1
DIRow = 1
DIColumn = 1
Dim PDCell As Range
Dim DICell As Range
Set PDCell = Worksheets("Processed Data").Cells(PDRow, PDColumn)
Set DICell = Worksheets("Data Input").Cells(DIRow, DIColumn)
Call moveCell(2, 0, "Data Input")
End Sub
'<<Function which moves the cell which defines the range>>'
Sub moveCell(r As Integer, c As Integer, sheet As String)
If sheet = "Processed Data" Then
PDRow = PDRow + r
PDColumn = PDColumn + c
Set PDCell = Worksheets("Data Input").Cells(PDRow, PDColumn)
ElseIf sheet = "Data Input" Then
DIRow = DIRow + r '<<<<<<This line does nothing to DIRow's value
DIColumn = DIColumn + c
Set DICell = Worksheets("Data Input").Cells(DIRow, DIColumn) '<<<<<<This line causes error 1004
End If
End Sub
As far as I can tell, you could instead use a quick Function instead. There doesn't seem to be any difference in your If statement results in the moveCell() function, except which worksheet you're using.
We can make this simpler by referring to the Range you're passing to moveCell.
Option Explicit ' forces you to declare all variables
Sub something()
Dim PDCell As Range
Set PDCell = Worksheets("Processed Data").Cells(1, 1)
Dim DICell As Range
Set DICell = Worksheets("Data Input").Cells(1, 1)
PDCell.Select ' can remove
Set PDCell = moveCell(2, 0, PDCell, PDCell.Worksheet.Name)
PDCell.Select ' can remove
Worksheets(DICell.Worksheet.Name).Activate ' can remove
DICell.Select ' can remove
Set DICell = moveCell(5, 0, DICell, DICell.Worksheet.Name)
DICell.Select ' can remove
End Sub
Function moveCell(rowsToMove As Long, colsToMove As Long, cel As Range, ws As String) As Range
Set moveCell = Worksheets(ws).Cells(cel.Row + rowsToMove, cel.Column + colsToMove)
End Function
I've included some rows you don't need (which I've marked with a comment afterwards), but that will show you how the routine works. You can step through with F8 to help see it step-by-step.
Edit: Although, you don't need a separate function at all. Just use OFFSET().
Set PDCell = ...whatever originally
Set PDCell = PDCell.Offset([rows],[cols])
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
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