For Each srs in cht.seriescollection not working
I use this to list the series on a new worksheet. I hope it helps.
Sub ChartSeriesListEmbedded()
Dim WS As Excel.Worksheet
Dim objCht As Excel.ChartObject
Dim xVal, yVal, SeriesFormula
Dim k, i
Dim lRow
Dim myWS As Excel.Worksheet
Dim aWB As Excel.Workbook
Dim myCount As Long
Set aWB = ActiveWorkbook
myCount = aWB.Charts.Count
For Each WS In aWB.Worksheets
myCount = WS.ChartObjects.Count + myCount
Next WS
If myCount = 0 Then
MsgBox ("There are no charts in the active workbook. Execution ending.")
End
End If
'MsgBox ("This procedure adds a worksheet")
aWB.Unprotect
On Error Resume Next
Set myWS = aWB.Worksheets("SeriesList")
On Error GoTo 0
If Not myWS Is Nothing Then
Application.DisplayAlerts = False
myWS.Delete
Application.DisplayAlerts = True
End If
Set myWS = aWB.Worksheets.Add(Befo=aWB.Worksheets(1))
myWS.Name = "SeriesList"
'lRow = Worksheets("SeriesList").Cells(Rows.Count, "a").End(xlUp).row
myWS.Cells(1, 1) = "Worksheet Name"
myWS.Cells(1, 2) = "Chart Name"
myWS.Cells(1, 3) = "Series Number"
myWS.Cells(1, 4) = "Series Formula"
lRow = 1
For Each WS In aWB.Worksheets
WS.Activate
For Each objCht In WS.ChartObjects
Debug.Print objCht.Name
With objCht.Chart
Debug.Print "count=", .SeriesCollection.Count
For k = 1 To .SeriesCollection.Count
'xVal = .SeriesCollection(k).XValues
'yVal = .SeriesCollection(k).Values
On Error Resume Next
SeriesFormula = "No data in series. Check manually"
SeriesFormula = .SeriesCollection(k).Formula
On Error GoTo 0
'Debug.Print WS.Name; " has chart; "; .Parent.Name; _
".; Series"; k; "; formula"; seriesformula
myWS.Range("a" & lRow + 1).Value = WS.Name
myWS.Range("b" & lRow + 1).Value = .Parent.Name
myWS.Range("c" & lRow + 1).Value = k
myWS.Range("d" & lRow + 1).Value = "'" & SeriesFormula
lRow = lRow + 1
Next k
End With
Next
Next WS
myWS.Select
myWS.Rows(1).Font.Bold = True
myWS.Rows(1).AutoFilter
myWS.UsedRange.EntireColumn.AutoFit
MsgBox ("Series List population complete.")
End Sub
"MikeZz" wrote:
Hi,
I have a very complex chart with about 400 lines on X-Y chart.
The issue is that not all the series have the same range as the "XValue" so
if I autofilter the data, it hides the Xvalue range on some series and so it
doesn't scale hte X-Axis correctly.
Because if this, I want to search through all the series where the data
comes from a worksheet with "data" in the name. Find the series that has the
"xValue" row at the top of the page and then set all the other data series
X-Values to the one at the top of the row.
Not all series point to the same data worksheet and there could be other
issues (I didn't build the chart).
Any help would be great!
Dim rngDataSource As Range
Dim iDataRowsCt As Long
Dim iDataColsCt As Integer
Dim iSrsIx As Integer
Dim chtChart As Chart
Dim srsNew As Series
Dim rngXVal As Range
Dim addXVals
Dim dataSheetName
Dim topXval
Dim thisXvalRow
Dim sCount
dataSheetName = "data"
topXval = 1000
Application.ScreenUpdating = False
Set cht = ActiveChart
If cht.ChartType = 0 Then Exit Sub
For Each srs In cht.SeriesCollection
addXVals = Extract_Series_Ranges(srs.FormulaR1C1, "X")
If InStr(1, srs.Name, "ARC") = 0 And InStr(1, srs.Name, "RIM") =
0 Then
If InStr(1, addXVals, dataSheetName) 0 Then
thisXvalRow = Range(addXVals).Row
If thisXvalRow < topXval Then
topXval = thisXvalRow
End If
End If
End If
Next
Application.ScreenUpdating = True
End Sub
Private Function Extract_Series_Ranges(SerForm, XorY)
Dim comma1, comma2, comma3, comma4
Dim xRange
Dim yRange
Dim nRange
Dim par1
Dim Ord
par1 = InStr(1, SerForm, "(")
comma1 = InStr(1, SerForm, ",")
comma2 = InStr(comma1 + 1, SerForm, ",")
comma3 = InStr(comma2 + 1, SerForm, ",")
comma4 = InStr(comma3 + 1, SerForm, ",")
nRange = Mid(SerForm, par1 + 1, comma1 - par1 - 1)
xRange = Mid(SerForm, comma1 + 1, comma2 - comma1 - 1)
yRange = Mid(SerForm, comma2 + 1, comma3 - comma2 - 1)
Ord = Mid(SerForm, comma3 + 1, Len(SerForm) - comma3 - 1)
Select Case XorY
Case "X"
Extract_Series_Ranges = xRange
Case "Y"
Extract_Series_Ranges = yRange
Case "Name"
Extract_Series_Ranges = nRange
Case "Ord"
Extract_Series_Ranges = Ord
End Select
End Function
|