Need help with SeriesCollection Object Please !

[Dan Thompson]

Here is my problem:
I am using ActiveChart.SeriesCollection(1).Formula to return string that
contains the location of the data for that series [ie.. =SERIES("NY
Jet",Table!$A$2750:$A$6500,Table!$C$2750:$C$5856,1)]

Then I am using a string parsing function I made to chop out the name of the
worksheet to which that SeriesCollection came from. This seems like more work
than it should be just to return the worksheet(name) that a particular
SeriesCollection in a chart belongs too.

There has to be an easier way ??
Any thoughts ??

Dan Thompson

 

[Peter T]

You're going about it the right way, extract the sheet name from the series
formula. You could show us your parsing routine in case it might be
simplified.

Regards,
Peter T

 

[Dan Thompson]

Darn I thought that in this day and age SeriesCollection Object would alread
have a built in property or method for returning the Worksheetname Guess I
will have to use my original method which does work just was hoping for a
shortcut

Here is the code I am using :

Sub GetSourceSheet()
SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

Keep in mind this code is only part of my entire program / macro
What the Entire Code does is remove all worksheets and data from a workbook
that does not directly or indirectly belong to the Active Chart
and than alows the user to save the end result as a new workbook. Thus not
overiting the original workbook.

If you are interested here is the Entire Working Code for this Macro

Option Base 1
Sub AddChartSeriesDataFilterMenuButton()
'*******Add's A Menu Button to Excel to run Procedure "CSDF" **********
Dim xlBar As CommandBar
Dim CustMnuBar As CommandBarButton
Set xlBar = Application.CommandBars("Chart Menu Bar")
Set CustMnuBar = xlBar.Controls.Add(Type:=msoControlButton, Temporary:=False)
CustMnuBar.Caption = "ChartSeriesDataFilter"
CustMnuBar.Style = msoButtonCaption
CustMnuBar.Visible = True
With CustMnuBar
.OnAction = "CSDF"
End With
End Sub
'#############################################################################
' Chart Series Data Filter [MACRO]
'
'Import this module into a workbook with charts you wish to run it on.
'Import this module into "Personal Workbook" to have access to it from any
Workbook.
'
'To run simply select a chart object, or chart Sheet and run the macro.
'The macro when run, will delete all charts and data out of the current
'workbook which are not relevent to the chart you selected to isolate.
'#############################################################################
Sub CSDF()
Dim ChartIndex As Integer, NumOfSeries As Integer, X As Integer, SheetCount
As Integer, y As Integer
Dim SeriesArray() As Variant, ColArray() As Variant
Dim ChartIsSheet As Boolean
Dim SheetName As String, SheetsToDel() As String, fileSaveName As String

SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate

For X = 1 To NumOfSeries
Range(ColArray(X) & ":" & ColArray(X)).Select 'Selects source data
column of a chart series
Selection.Interior.ColorIndex = 4 'Colors chart series data column
bright green
Range(ColArray(X) & ":" &
ColArray(X)).Precedents.Columns.EntireColumn.Select 'The Precedents command
Returns a Range object that represents all the precedents(links) of a cell
If Not Err.Number = 1004 Then 'Error 1004 is "No Cells Were Found"
Meaning there are no Precedents(Links) for the cells.
Selection.Interior.ColorIndex = 35 'colors all precendent(Linked)
cells light pastell green
End If
Next X

Err.Clear
Resume
GetNonGreenColPos

If ChartIsSheet = False Then
Sheets(SheetName).Activate
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="NewChart"
ElseIf ChartIsSheet = True Then
Sheets(SheetName).Activate
Sheets(SheetName).Name = "NewChart"
End If

SheetCount = ActiveWorkbook.Sheets.Count

For y = 1 To SheetCount
If Not Sheets(y).Name = SourceWrksheet Then
If Not Sheets(y).Name = "NewChart" Then
t = t + 1
ReDim Preserve SheetsToDel(t)
SheetsToDel(t) = Sheets(y).Name
End If
End If
Next y

Application.DisplayAlerts = False ' prevent nags
For y = LBound(SheetsToDel) To UBound(SheetsToDel)
Sheets(SheetsToDel(y)).Delete
Next y
Application.DisplayAlerts = True
With Application
fileSaveName =
Application.GetSaveAsFilename(InitialFilename:="NewChart.xls",
fileFilter:="Excel File (*.xls), *.xls")
End With
ActiveWorkbook.SaveAs Filename:=fileSaveName, FileFormat:=xlNormal
ActiveWorkbook.Close (True)
End Sub
Sub GetNonGreenColPos()
Dim N As Integer, a As Integer, z As Integer, FirstOcurance As Integer,
SecondOcurance As Integer
Dim CurCelAddress As String, NonGreenColArray() As String, MyRangeString As
String
Dim rngToDelete As Range

With ActiveSheet
a = 0
For N = 1 To 256
If Not Cells(1, N).Interior.ColorIndex = 4 Then
If Not Cells(1, N).Interior.ColorIndex = 35 Then
CurCelAddress = Cells(1, N).Address
FirstOcurance = InStr(1, CurCelAddress, "$")
SecondOcurance = InStr(FirstOcurance + 1, CurCelAddress, "$")
NonGreenCol = Mid(CurCelAddress, FirstOcurance + 1,
SecondOcurance - (FirstOcurance + 1))
a = a + 1
ReDim Preserve NonGreenColArray(a)
NonGreenColArray(a) = NonGreenCol
End If
End If
Next N

Set rngToDelete = Columns(NonGreenColArray(2))
For z = 3 To UBound(NonGreenColArray())
Set rngToDelete = Union(rngToDelete, Columns(NonGreenColArray(z)))
Next z
'rngToDelete.Select 'For Just Selection of Data Columns linked to Chart
Series.
rngToDelete.Delete 'To delete all data columns not relevent to selected chart.
End With
End Sub
Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function
Function DataCol(ByVal DataRange As String) As String
'*****************************************************
'Returns single Column letter from a "A1" Style Range
'
'Example:
' MyRangeString = "'Data Calc'!$A$4:$A$20"
' MyColLetter = DataCol(MyRangeString)
'
' Returns String: A
'*****************************************************
Dim t As Integer, X As Integer
X = Len(DataRange)
For t = 1 To X
If Left(Right(DataRange, t), 1) = "!" Then
If Left(Right(DataRange, t - 3), 1) = "$" Then
DataCol = Left(Right(DataRange, t - 2), 1)
Exit For
Else
DataCol = Left(Right(DataRange, t - 2), 2)
Exit For
End If
End If
Next t
End Function

You're going about it the right way, extract the sheet name from the series
formula. You could show us your parsing routine in case it might be
simplified.

Regards,
Peter T

Here is my problem:
I am using ActiveChart.SeriesCollection(1).Formula to return string that
contains the location of the data for that series [ie.. =SERIES("NY
Jet",Table!$A$2750:$A$6500,Table!$C$2750:$C$5856,1)]

Then I am using a string parsing function I made to chop out the name of
the
worksheet to which that SeriesCollection came from. This seems like more
work
than it should be just to return the worksheet(name) that a particular
SeriesCollection in a chart belongs too.

There has to be an easier way ??
Any thoughts ??

Dan Thompson

 

[Peter T]

Your GetSheetName routine doesn't seem right, I get ",Sheet1" with the
preceding comma
The following if anything is slightly more complicated, but more reliable.
It will also return the workbook name which might be relevant if the data
and chart are not in same file.

Sub test()
Dim s As String
Dim sWSname As String, sFile As String

s = ActiveChart.SeriesCollection(1).Formula

If GetSourceSheet(s, sWSname, sFile) Then
MsgBox sWSname & vbCr & sFile
Else
MsgBox "source not determined" '(eg array or named formula)
End If

End Sub


Function GetSourceSheet(sFmla As String, sWSname, sFile As String) As
Boolean
Dim i As Long
Dim arr
Dim rng As Range

On Error Resume Next
arr = Split(Mid$(sFmla, 9, Len(sFmla) - 9), ",")
For i = UBound(arr) - 1 To 0 Step -1
Set rng = Range(arr(i))
If Not rng Is Nothing Then
sWSname = rng.Parent.Name
sFile = rng.Parent.Parent.Name
GetSourceSheet = True
Exit For
End If
Next
End Function


If I follow you are trying to remove all but essential chart data. I have an
addin that replaces source data in cells with source data in named arrays or
arrays in the series formula (latter subject relatively small data limits
per series). IOW, can end up with a workbook with zero data in cells, or if
charts are chart-sheets zero worksheets. Contact me if interested (my
address is in the reply-to field).

Regards,
Peter T

Darn I thought that in this day and age SeriesCollection Object would
alread
have a built in property or method for returning the Worksheetname Guess I
will have to use my original method which does work just was hoping for a
shortcut

Here is the code I am using :

Sub GetSourceSheet()
SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

Keep in mind this code is only part of my entire program / macro
What the Entire Code does is remove all worksheets and data from a
workbook
that does not directly or indirectly belong to the Active Chart
and than alows the user to save the end result as a new workbook. Thus not
overiting the original workbook.

If you are interested here is the Entire Working Code for this Macro

Option Base 1
Sub AddChartSeriesDataFilterMenuButton()
'*******Add's A Menu Button to Excel to run Procedure "CSDF" **********
Dim xlBar As CommandBar
Dim CustMnuBar As CommandBarButton
Set xlBar = Application.CommandBars("Chart Menu Bar")
Set CustMnuBar = xlBar.Controls.Add(Type:=msoControlButton,
Temporary:=False)
CustMnuBar.Caption = "ChartSeriesDataFilter"
CustMnuBar.Style = msoButtonCaption
CustMnuBar.Visible = True
With CustMnuBar
.OnAction = "CSDF"
End With
End Sub
'#############################################################################
' Chart Series Data Filter [MACRO]
'
'Import this module into a workbook with charts you wish to run it on.
'Import this module into "Personal Workbook" to have access to it from any
Workbook.
'
'To run simply select a chart object, or chart Sheet and run the macro.
'The macro when run, will delete all charts and data out of the current
'workbook which are not relevent to the chart you selected to isolate.
'#############################################################################
Sub CSDF()
Dim ChartIndex As Integer, NumOfSeries As Integer, X As Integer,
SheetCount
As Integer, y As Integer
Dim SeriesArray() As Variant, ColArray() As Variant
Dim ChartIsSheet As Boolean
Dim SheetName As String, SheetsToDel() As String, fileSaveName As String

SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate

For X = 1 To NumOfSeries
Range(ColArray(X) & ":" & ColArray(X)).Select 'Selects source data
column of a chart series
Selection.Interior.ColorIndex = 4 'Colors chart series data column
bright green
Range(ColArray(X) & ":" &
ColArray(X)).Precedents.Columns.EntireColumn.Select 'The Precedents
command
Returns a Range object that represents all the precedents(links) of a cell
If Not Err.Number = 1004 Then 'Error 1004 is "No Cells Were Found"
Meaning there are no Precedents(Links) for the cells.
Selection.Interior.ColorIndex = 35 'colors all precendent(Linked)
cells light pastell green
End If
Next X

Err.Clear
Resume
GetNonGreenColPos

If ChartIsSheet = False Then
Sheets(SheetName).Activate
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="NewChart"
ElseIf ChartIsSheet = True Then
Sheets(SheetName).Activate
Sheets(SheetName).Name = "NewChart"
End If

SheetCount = ActiveWorkbook.Sheets.Count

For y = 1 To SheetCount
If Not Sheets(y).Name = SourceWrksheet Then
If Not Sheets(y).Name = "NewChart" Then
t = t + 1
ReDim Preserve SheetsToDel(t)
SheetsToDel(t) = Sheets(y).Name
End If
End If
Next y

Application.DisplayAlerts = False ' prevent nags
For y = LBound(SheetsToDel) To UBound(SheetsToDel)
Sheets(SheetsToDel(y)).Delete
Next y
Application.DisplayAlerts = True
With Application
fileSaveName =
Application.GetSaveAsFilename(InitialFilename:="NewChart.xls",
fileFilter:="Excel File (*.xls), *.xls")
End With
ActiveWorkbook.SaveAs Filename:=fileSaveName, FileFormat:=xlNormal
ActiveWorkbook.Close (True)
End Sub
Sub GetNonGreenColPos()
Dim N As Integer, a As Integer, z As Integer, FirstOcurance As Integer,
SecondOcurance As Integer
Dim CurCelAddress As String, NonGreenColArray() As String, MyRangeString
As
String
Dim rngToDelete As Range

With ActiveSheet
a = 0
For N = 1 To 256
If Not Cells(1, N).Interior.ColorIndex = 4 Then
If Not Cells(1, N).Interior.ColorIndex = 35 Then
CurCelAddress = Cells(1, N).Address
FirstOcurance = InStr(1, CurCelAddress, "$")
SecondOcurance = InStr(FirstOcurance + 1, CurCelAddress,
"$")
NonGreenCol = Mid(CurCelAddress, FirstOcurance + 1,
SecondOcurance - (FirstOcurance + 1))
a = a + 1
ReDim Preserve NonGreenColArray(a)
NonGreenColArray(a) = NonGreenCol
End If
End If
Next N

Set rngToDelete = Columns(NonGreenColArray(2))
For z = 3 To UBound(NonGreenColArray())
Set rngToDelete = Union(rngToDelete, Columns(NonGreenColArray(z)))
Next z
'rngToDelete.Select 'For Just Selection of Data Columns linked to Chart
Series.
rngToDelete.Delete 'To delete all data columns not relevent to selected
chart.
End With
End Sub
Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function
Function DataCol(ByVal DataRange As String) As String
'*****************************************************
'Returns single Column letter from a "A1" Style Range
'
'Example:
' MyRangeString = "'Data Calc'!$A$4:$A$20"
' MyColLetter = DataCol(MyRangeString)
'
' Returns String: A
'*****************************************************
Dim t As Integer, X As Integer
X = Len(DataRange)
For t = 1 To X
If Left(Right(DataRange, t), 1) = "!" Then
If Left(Right(DataRange, t - 3), 1) = "$" Then
DataCol = Left(Right(DataRange, t - 2), 1)
Exit For
Else
DataCol = Left(Right(DataRange, t - 2), 2)
Exit For
End If
End If
Next t
End Function

You're going about it the right way, extract the sheet name from the
series
formula. You could show us your parsing routine in case it might be
simplified.

Regards,
Peter T

Here is my problem:
I am using ActiveChart.SeriesCollection(1).Formula to return string
that
contains the location of the data for that series [ie.. =SERIES("NY
Jet",Table!$A$2750:$A$6500,Table!$C$2750:$C$5856,1)]

Then I am using a string parsing function I made to chop out the name
of
the
worksheet to which that SeriesCollection came from. This seems like
more
work
than it should be just to return the worksheet(name) that a particular
SeriesCollection in a chart belongs too.

There has to be an easier way ??
Any thoughts ??

Dan Thompson

 

[Dan Thompson]

Thanks Peter for your repsonse

That is strange when I use my code it returns the Sheet Name (String) Fine
without the preceding comma I did notice that you are using
Activechart.Seriescollection(1).formula I am using .formulalocal I don't know
if that makes a differnce in the string returned having a preceding comma
perhaps my math is off by 1 placement in the string but strangely enough my
code works on my system ? I am using Excel 2000 so I don't know if that has
somthing to do with it.

But yes you are right the objective of the macro is to remove all data that
is not relevent to the active chart. I am not conserned at this time with
charts that are linked to data in different workbooks however you bring up a
good point that I may need to incorporate into this code in the future.

I will try your code out and compare thanks for your input on this today.

Dan Thompson

Your GetSheetName routine doesn't seem right, I get ",Sheet1" with the
preceding comma
The following if anything is slightly more complicated, but more reliable.
It will also return the workbook name which might be relevant if the data
and chart are not in same file.

Sub test()
Dim s As String
Dim sWSname As String, sFile As String

s = ActiveChart.SeriesCollection(1).Formula

If GetSourceSheet(s, sWSname, sFile) Then
MsgBox sWSname & vbCr & sFile
Else
MsgBox "source not determined" '(eg array or named formula)
End If

End Sub


Function GetSourceSheet(sFmla As String, sWSname, sFile As String) As
Boolean
Dim i As Long
Dim arr
Dim rng As Range

On Error Resume Next
arr = Split(Mid$(sFmla, 9, Len(sFmla) - 9), ",")
For i = UBound(arr) - 1 To 0 Step -1
Set rng = Range(arr(i))
If Not rng Is Nothing Then
sWSname = rng.Parent.Name
sFile = rng.Parent.Parent.Name
GetSourceSheet = True
Exit For
End If
Next
End Function


If I follow you are trying to remove all but essential chart data. I have an
addin that replaces source data in cells with source data in named arrays or
arrays in the series formula (latter subject relatively small data limits
per series). IOW, can end up with a workbook with zero data in cells, or if
charts are chart-sheets zero worksheets. Contact me if interested (my
address is in the reply-to field).

Regards,
Peter T

Darn I thought that in this day and age SeriesCollection Object would
alread
have a built in property or method for returning the Worksheetname Guess I
will have to use my original method which does work just was hoping for a
shortcut

Here is the code I am using :

Sub GetSourceSheet()
SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

Keep in mind this code is only part of my entire program / macro
What the Entire Code does is remove all worksheets and data from a
workbook
that does not directly or indirectly belong to the Active Chart
and than alows the user to save the end result as a new workbook. Thus not
overiting the original workbook.

If you are interested here is the Entire Working Code for this Macro

Option Base 1
Sub AddChartSeriesDataFilterMenuButton()
'*******Add's A Menu Button to Excel to run Procedure "CSDF" **********
Dim xlBar As CommandBar
Dim CustMnuBar As CommandBarButton
Set xlBar = Application.CommandBars("Chart Menu Bar")
Set CustMnuBar = xlBar.Controls.Add(Type:=msoControlButton,
Temporary:=False)
CustMnuBar.Caption = "ChartSeriesDataFilter"
CustMnuBar.Style = msoButtonCaption
CustMnuBar.Visible = True
With CustMnuBar
.OnAction = "CSDF"
End With
End Sub
'#############################################################################
' Chart Series Data Filter [MACRO]
'
'Import this module into a workbook with charts you wish to run it on.
'Import this module into "Personal Workbook" to have access to it from any
Workbook.
'
'To run simply select a chart object, or chart Sheet and run the macro.
'The macro when run, will delete all charts and data out of the current
'workbook which are not relevent to the chart you selected to isolate.
'#############################################################################
Sub CSDF()
Dim ChartIndex As Integer, NumOfSeries As Integer, X As Integer,
SheetCount
As Integer, y As Integer
Dim SeriesArray() As Variant, ColArray() As Variant
Dim ChartIsSheet As Boolean
Dim SheetName As String, SheetsToDel() As String, fileSaveName As String

SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate

For X = 1 To NumOfSeries
Range(ColArray(X) & ":" & ColArray(X)).Select 'Selects source data
column of a chart series
Selection.Interior.ColorIndex = 4 'Colors chart series data column
bright green
Range(ColArray(X) & ":" &
ColArray(X)).Precedents.Columns.EntireColumn.Select 'The Precedents
command
Returns a Range object that represents all the precedents(links) of a cell
If Not Err.Number = 1004 Then 'Error 1004 is "No Cells Were Found"
Meaning there are no Precedents(Links) for the cells.
Selection.Interior.ColorIndex = 35 'colors all precendent(Linked)
cells light pastell green
End If
Next X

Err.Clear
Resume
GetNonGreenColPos

If ChartIsSheet = False Then
Sheets(SheetName).Activate
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="NewChart"
ElseIf ChartIsSheet = True Then
Sheets(SheetName).Activate
Sheets(SheetName).Name = "NewChart"
End If

SheetCount = ActiveWorkbook.Sheets.Count

For y = 1 To SheetCount
If Not Sheets(y).Name = SourceWrksheet Then
If Not Sheets(y).Name = "NewChart" Then
t = t + 1
ReDim Preserve SheetsToDel(t)
SheetsToDel(t) = Sheets(y).Name
End If
End If
Next y

Application.DisplayAlerts = False ' prevent nags
For y = LBound(SheetsToDel) To UBound(SheetsToDel)
Sheets(SheetsToDel(y)).Delete
Next y
Application.DisplayAlerts = True
With Application
fileSaveName =
Application.GetSaveAsFilename(InitialFilename:="NewChart.xls",
fileFilter:="Excel File (*.xls), *.xls")
End With
ActiveWorkbook.SaveAs Filename:=fileSaveName, FileFormat:=xlNormal
ActiveWorkbook.Close (True)
End Sub
Sub GetNonGreenColPos()
Dim N As Integer, a As Integer, z As Integer, FirstOcurance As Integer,
SecondOcurance As Integer
Dim CurCelAddress As String, NonGreenColArray() As String, MyRangeString
As
String
Dim rngToDelete As Range

With ActiveSheet
a = 0
For N = 1 To 256
If Not Cells(1, N).Interior.ColorIndex = 4 Then
If Not Cells(1, N).Interior.ColorIndex = 35 Then
CurCelAddress = Cells(1, N).Address
FirstOcurance = InStr(1, CurCelAddress, "$")
SecondOcurance = InStr(FirstOcurance + 1, CurCelAddress,
"$")
NonGreenCol = Mid(CurCelAddress, FirstOcurance + 1,
SecondOcurance - (FirstOcurance + 1))
a = a + 1
ReDim Preserve NonGreenColArray(a)
NonGreenColArray(a) = NonGreenCol
End If
End If
Next N

Set rngToDelete = Columns(NonGreenColArray(2))
For z = 3 To UBound(NonGreenColArray())
Set rngToDelete = Union(rngToDelete, Columns(NonGreenColArray(z)))
Next z
'rngToDelete.Select 'For Just Selection of Data Columns linked to Chart
Series.
rngToDelete.Delete 'To delete all data columns not relevent to selected
chart.
End With
End Sub
Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function
Function DataCol(ByVal DataRange As String) As String
'*****************************************************
'Returns single Column letter from a "A1" Style Range
'
'Example:
' MyRangeString = "'Data Calc'!$A$4:$A$20"
' MyColLetter = DataCol(MyRangeString)
'
' Returns String: A
'*****************************************************
Dim t As Integer, X As Integer
X = Len(DataRange)
For t = 1 To X
If Left(Right(DataRange, t), 1) = "!" Then
If Left(Right(DataRange, t - 3), 1) = "$" Then
DataCol = Left(Right(DataRange, t - 2), 1)
Exit For
Else
DataCol = Left(Right(DataRange, t - 2), 2)
Exit For
End If
End If
Next t
End Function

You're going about it the right way, extract the sheet name from the
series
formula. You could show us your parsing routine in case it might be
simplified.

Regards,
Peter T

 

[Peter T]

That is strange when I use my code it returns the Sheet Name (String) Fine

without the preceding comma I did notice that you are using
Activechart.Seriescollection(1).formula I am using .formulalocal

Sub test3()
Dim s As String
s = ActiveChart.SeriesCollection(1).Formula
Debug.Print "Formula", s
Debug.Print GetSheetName(s)
s = ActiveChart.SeriesCollection(1).FormulaLocal
Debug.Print "FormulaLocal", s
Debug.Print GetSheetName(s)
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

debug results

Formula =SERIES(,,Sheet1!$A$1:$A$3,1)
,Sheet1
FormulaLocal =SERIES(,,Sheet1!$A$1:$A$3,1)
,Sheet1

As you can see, a comma both ways

I am using Excel 2000 so I don't know if that has
somthing to do with it.

No, that wouldn't make a difference, but if the series name is linked to a
cell it would (but can't be sure it always is).

I am not conserned at this time with
charts that are linked to data in different workbooks

The addin I mentioned also has a function to "resource" data from one
location to another, eg from an external wb to the chart wb. To cater for
most scenarios was amount of work.

Regards,
Peter T

Thanks Peter for your repsonse

That is strange when I use my code it returns the Sheet Name (String) Fine
without the preceding comma I did notice that you are using
Activechart.Seriescollection(1).formula I am using .formulalocal I don't
know
if that makes a differnce in the string returned having a preceding comma
perhaps my math is off by 1 placement in the string but strangely enough
my
code works on my system ? I am using Excel 2000 so I don't know if that
has
somthing to do with it.

But yes you are right the objective of the macro is to remove all data
that
is not relevent to the active chart. I am not conserned at this time with
charts that are linked to data in different workbooks however you bring up
a
good point that I may need to incorporate into this code in the future.

I will try your code out and compare thanks for your input on this today.

Dan Thompson

Your GetSheetName routine doesn't seem right, I get ",Sheet1" with the
preceding comma
The following if anything is slightly more complicated, but more
reliable.
It will also return the workbook name which might be relevant if the data
and chart are not in same file.

Sub test()
Dim s As String
Dim sWSname As String, sFile As String

s = ActiveChart.SeriesCollection(1).Formula

If GetSourceSheet(s, sWSname, sFile) Then
MsgBox sWSname & vbCr & sFile
Else
MsgBox "source not determined" '(eg array or named formula)
End If

End Sub


Function GetSourceSheet(sFmla As String, sWSname, sFile As String) As
Boolean
Dim i As Long
Dim arr
Dim rng As Range

On Error Resume Next
arr = Split(Mid$(sFmla, 9, Len(sFmla) - 9), ",")
For i = UBound(arr) - 1 To 0 Step -1
Set rng = Range(arr(i))
If Not rng Is Nothing Then
sWSname = rng.Parent.Name
sFile = rng.Parent.Parent.Name
GetSourceSheet = True
Exit For
End If
Next
End Function


If I follow you are trying to remove all but essential chart data. I have
an
addin that replaces source data in cells with source data in named arrays
or
arrays in the series formula (latter subject relatively small data limits
per series). IOW, can end up with a workbook with zero data in cells, or
if
charts are chart-sheets zero worksheets. Contact me if interested (my
address is in the reply-to field).

Regards,
Peter T

Darn I thought that in this day and age SeriesCollection Object would
alread
have a built in property or method for returning the Worksheetname
Guess I
will have to use my original method which does work just was hoping for
a
shortcut

Here is the code I am using :

Sub GetSourceSheet()
SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not
a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

Keep in mind this code is only part of my entire program / macro
What the Entire Code does is remove all worksheets and data from a
workbook
that does not directly or indirectly belong to the Active Chart
and than alows the user to save the end result as a new workbook. Thus
not
overiting the original workbook.

If you are interested here is the Entire Working Code for this Macro

Option Base 1
Sub AddChartSeriesDataFilterMenuButton()
'*******Add's A Menu Button to Excel to run Procedure "CSDF" **********
Dim xlBar As CommandBar
Dim CustMnuBar As CommandBarButton
Set xlBar = Application.CommandBars("Chart Menu Bar")
Set CustMnuBar = xlBar.Controls.Add(Type:=msoControlButton,
Temporary:=False)
CustMnuBar.Caption = "ChartSeriesDataFilter"
CustMnuBar.Style = msoButtonCaption
CustMnuBar.Visible = True
With CustMnuBar
.OnAction = "CSDF"
End With
End Sub
'#############################################################################
' Chart Series Data Filter [MACRO]
'
'Import this module into a workbook with charts you wish to run it on.
'Import this module into "Personal Workbook" to have access to it from
any
Workbook.
'
'To run simply select a chart object, or chart Sheet and run the macro.
'The macro when run, will delete all charts and data out of the current
'workbook which are not relevent to the chart you selected to isolate.
'#############################################################################
Sub CSDF()
Dim ChartIndex As Integer, NumOfSeries As Integer, X As Integer,
SheetCount
As Integer, y As Integer
Dim SeriesArray() As Variant, ColArray() As Variant
Dim ChartIsSheet As Boolean
Dim SheetName As String, SheetsToDel() As String, fileSaveName As
String

SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not
a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate

For X = 1 To NumOfSeries
Range(ColArray(X) & ":" & ColArray(X)).Select 'Selects source data
column of a chart series
Selection.Interior.ColorIndex = 4 'Colors chart series data column
bright green
Range(ColArray(X) & ":" &
ColArray(X)).Precedents.Columns.EntireColumn.Select 'The Precedents
command
Returns a Range object that represents all the precedents(links) of a
cell
If Not Err.Number = 1004 Then 'Error 1004 is "No Cells Were Found"
Meaning there are no Precedents(Links) for the cells.
Selection.Interior.ColorIndex = 35 'colors all
precendent(Linked)
cells light pastell green
End If
Next X

Err.Clear
Resume
GetNonGreenColPos

If ChartIsSheet = False Then
Sheets(SheetName).Activate
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="NewChart"
ElseIf ChartIsSheet = True Then
Sheets(SheetName).Activate
Sheets(SheetName).Name = "NewChart"
End If

SheetCount = ActiveWorkbook.Sheets.Count

For y = 1 To SheetCount
If Not Sheets(y).Name = SourceWrksheet Then
If Not Sheets(y).Name = "NewChart" Then
t = t + 1
ReDim Preserve SheetsToDel(t)
SheetsToDel(t) = Sheets(y).Name
End If
End If
Next y

Application.DisplayAlerts = False ' prevent nags
For y = LBound(SheetsToDel) To UBound(SheetsToDel)
Sheets(SheetsToDel(y)).Delete
Next y
Application.DisplayAlerts = True
With Application
fileSaveName =
Application.GetSaveAsFilename(InitialFilename:="NewChart.xls",
fileFilter:="Excel File (*.xls), *.xls")
End With
ActiveWorkbook.SaveAs Filename:=fileSaveName, FileFormat:=xlNormal
ActiveWorkbook.Close (True)
End Sub
Sub GetNonGreenColPos()
Dim N As Integer, a As Integer, z As Integer, FirstOcurance As Integer,
SecondOcurance As Integer
Dim CurCelAddress As String, NonGreenColArray() As String,
MyRangeString
As
String
Dim rngToDelete As Range

With ActiveSheet
a = 0
For N = 1 To 256
If Not Cells(1, N).Interior.ColorIndex = 4 Then
If Not Cells(1, N).Interior.ColorIndex = 35 Then
CurCelAddress = Cells(1, N).Address
FirstOcurance = InStr(1, CurCelAddress, "$")
SecondOcurance = InStr(FirstOcurance + 1, CurCelAddress,
"$")
NonGreenCol = Mid(CurCelAddress, FirstOcurance + 1,
SecondOcurance - (FirstOcurance + 1))
a = a + 1
ReDim Preserve NonGreenColArray(a)
NonGreenColArray(a) = NonGreenCol
End If
End If
Next N

Set rngToDelete = Columns(NonGreenColArray(2))
For z = 3 To UBound(NonGreenColArray())
Set rngToDelete = Union(rngToDelete, Columns(NonGreenColArray(z)))
Next z
'rngToDelete.Select 'For Just Selection of Data Columns linked to Chart
Series.
rngToDelete.Delete 'To delete all data columns not relevent to selected
chart.
End With
End Sub
Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function
Function DataCol(ByVal DataRange As String) As String
'*****************************************************
'Returns single Column letter from a "A1" Style Range
'
'Example:
' MyRangeString = "'Data Calc'!$A$4:$A$20"
' MyColLetter = DataCol(MyRangeString)
'
' Returns String: A
'*****************************************************
Dim t As Integer, X As Integer
X = Len(DataRange)
For t = 1 To X
If Left(Right(DataRange, t), 1) = "!" Then
If Left(Right(DataRange, t - 3), 1) = "$" Then
DataCol = Left(Right(DataRange, t - 2), 1)
Exit For
Else
DataCol = Left(Right(DataRange, t - 2), 2)
Exit For
End If
End If
Next t
End Function



:

You're going about it the right way, extract the sheet name from the
series
formula. You could show us your parsing routine in case it might be
simplified.

Regards,
Peter T

 

[Dan Thompson]

Well Peter you have got me scratching my head on this one I noticed when I
ran my code on certain other charts sometimes it would return ('Sheet1') and
other charts it would return as it should (Sheet1) so I changed my code to
use .FormulaR1C1Local and that seems to work consistantly for both the charts
that were returning normal (Sheet1) and the ones that were returning
('Sheet1') I don't know why you are getting the comma though I have run
several tests and I am not getting the preceding comma, like I said I did
have some issues with some charts returning with preceding and post single
quotes ('Sheet1') however the .FormulaR1C1local seems to do the trick for
eliminating that problem

I ran your test code though and here are the results for all the .formula
methods used plus I added the R1C1 too.

Sub test3()
Dim s As String
s = ActiveChart.SeriesCollection(1).Formula
Debug.Print "Formula", s
Debug.Print GetSheetName(s)
s = ActiveChart.SeriesCollection(1).FormulaLocal
Debug.Print "FormulaLocal", s
Debug.Print GetSheetName(s)
s = ActiveChart.SeriesCollection(1).FormulaR1C1Local
Debug.Print "FormulaR1C1Local", s
Debug.Print GetSheetName(s)
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

debug results

Formula =SERIES("20d MA Spot
Price",Sheet1!$A$2312:$A$5852,Sheet1!$E$2312:$E$5852,1)
Sheet1
FormulaLocal =SERIES("20d MA Spot
Price",Sheet1!$A$2312:$A$5852,Sheet1!$E$2312:$E$5852,1)
Sheet1
FormulaR1C1Local =SERIES("20d MA Spot
Price",Sheet1!R2312C1:R5852C1,Sheet1!R2312C5:R5852C5,1)
Sheet1

Only thing I can figure is maybe difference in Excel versions being used
like I said I am using Excel 2000 perhaps newer versions handle things
differently ??

Dan Thompson

That is strange when I use my code it returns the Sheet Name (String) Fine
without the preceding comma I did notice that you are using
Activechart.Seriescollection(1).formula I am using .formulalocal

Sub test3()
Dim s As String
s = ActiveChart.SeriesCollection(1).Formula
Debug.Print "Formula", s
Debug.Print GetSheetName(s)
s = ActiveChart.SeriesCollection(1).FormulaLocal
Debug.Print "FormulaLocal", s
Debug.Print GetSheetName(s)
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

debug results

Formula =SERIES(,,Sheet1!$A$1:$A$3,1)
,Sheet1
FormulaLocal =SERIES(,,Sheet1!$A$1:$A$3,1)
,Sheet1

As you can see, a comma both ways

I am using Excel 2000 so I don't know if that has
somthing to do with it.

No, that wouldn't make a difference, but if the series name is linked to a
cell it would (but can't be sure it always is).

I am not conserned at this time with
charts that are linked to data in different workbooks

The addin I mentioned also has a function to "resource" data from one
location to another, eg from an external wb to the chart wb. To cater for
most scenarios was amount of work.

Regards,
Peter T

Thanks Peter for your repsonse

That is strange when I use my code it returns the Sheet Name (String) Fine
without the preceding comma I did notice that you are using
Activechart.Seriescollection(1).formula I am using .formulalocal I don't
know
if that makes a differnce in the string returned having a preceding comma
perhaps my math is off by 1 placement in the string but strangely enough
my
code works on my system ? I am using Excel 2000 so I don't know if that
has
somthing to do with it.

But yes you are right the objective of the macro is to remove all data
that
is not relevent to the active chart. I am not conserned at this time with
charts that are linked to data in different workbooks however you bring up
a
good point that I may need to incorporate into this code in the future.

I will try your code out and compare thanks for your input on this today.

Dan Thompson

Your GetSheetName routine doesn't seem right, I get ",Sheet1" with the
preceding comma
The following if anything is slightly more complicated, but more
reliable.
It will also return the workbook name which might be relevant if the data
and chart are not in same file.

Sub test()
Dim s As String
Dim sWSname As String, sFile As String

s = ActiveChart.SeriesCollection(1).Formula

If GetSourceSheet(s, sWSname, sFile) Then
MsgBox sWSname & vbCr & sFile
Else
MsgBox "source not determined" '(eg array or named formula)
End If

End Sub


Function GetSourceSheet(sFmla As String, sWSname, sFile As String) As
Boolean
Dim i As Long
Dim arr
Dim rng As Range

On Error Resume Next
arr = Split(Mid$(sFmla, 9, Len(sFmla) - 9), ",")
For i = UBound(arr) - 1 To 0 Step -1
Set rng = Range(arr(i))
If Not rng Is Nothing Then
sWSname = rng.Parent.Name
sFile = rng.Parent.Parent.Name
GetSourceSheet = True
Exit For
End If
Next
End Function


If I follow you are trying to remove all but essential chart data. I have
an
addin that replaces source data in cells with source data in named arrays
or
arrays in the series formula (latter subject relatively small data limits
per series). IOW, can end up with a workbook with zero data in cells, or
if
charts are chart-sheets zero worksheets. Contact me if interested (my
address is in the reply-to field).

Regards,
Peter T


Darn I thought that in this day and age SeriesCollection Object would
alread
have a built in property or method for returning the Worksheetname
Guess I
will have to use my original method which does work just was hoping for
a
shortcut

Here is the code I am using :

Sub GetSourceSheet()
SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not
a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

Keep in mind this code is only part of my entire program / macro
What the Entire Code does is remove all worksheets and data from a
workbook
that does not directly or indirectly belong to the Active Chart
and than alows the user to save the end result as a new workbook. Thus
not
overiting the original workbook.

If you are interested here is the Entire Working Code for this Macro

Option Base 1
Sub AddChartSeriesDataFilterMenuButton()
'*******Add's A Menu Button to Excel to run Procedure "CSDF" **********
Dim xlBar As CommandBar
Dim CustMnuBar As CommandBarButton
Set xlBar = Application.CommandBars("Chart Menu Bar")
Set CustMnuBar = xlBar.Controls.Add(Type:=msoControlButton,
Temporary:=False)
CustMnuBar.Caption = "ChartSeriesDataFilter"
CustMnuBar.Style = msoButtonCaption
CustMnuBar.Visible = True
With CustMnuBar
.OnAction = "CSDF"
End With
End Sub
'#############################################################################
' Chart Series Data Filter [MACRO]
'
'Import this module into a workbook with charts you wish to run it on.
'Import this module into "Personal Workbook" to have access to it from
any
Workbook.
'
'To run simply select a chart object, or chart Sheet and run the macro.
'The macro when run, will delete all charts and data out of the current
'workbook which are not relevent to the chart you selected to isolate.
'#############################################################################
Sub CSDF()
Dim ChartIndex As Integer, NumOfSeries As Integer, X As Integer,
SheetCount
As Integer, y As Integer
Dim SeriesArray() As Variant, ColArray() As Variant
Dim ChartIsSheet As Boolean
Dim SheetName As String, SheetsToDel() As String, fileSaveName As
String

SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is not
a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate

For X = 1 To NumOfSeries
Range(ColArray(X) & ":" & ColArray(X)).Select 'Selects source data
column of a chart series
Selection.Interior.ColorIndex = 4 'Colors chart series data column
bright green
Range(ColArray(X) & ":" &
ColArray(X)).Precedents.Columns.EntireColumn.Select 'The Precedents
command
Returns a Range object that represents all the precedents(links) of a
cell
If Not Err.Number = 1004 Then 'Error 1004 is "No Cells Were Found"
Meaning there are no Precedents(Links) for the cells.
Selection.Interior.ColorIndex = 35 'colors all
precendent(Linked)
cells light pastell green
End If
Next X

Err.Clear
Resume
GetNonGreenColPos

If ChartIsSheet = False Then
Sheets(SheetName).Activate
ActiveChart.Location Where:=xlLocationAsNewSheet, Name:="NewChart"
ElseIf ChartIsSheet = True Then
Sheets(SheetName).Activate
Sheets(SheetName).Name = "NewChart"
End If

SheetCount = ActiveWorkbook.Sheets.Count

For y = 1 To SheetCount
If Not Sheets(y).Name = SourceWrksheet Then
If Not Sheets(y).Name = "NewChart" Then
t = t + 1
ReDim Preserve SheetsToDel(t)
SheetsToDel(t) = Sheets(y).Name
End If
End If
Next y

Application.DisplayAlerts = False ' prevent nags
For y = LBound(SheetsToDel) To UBound(SheetsToDel)
Sheets(SheetsToDel(y)).Delete
Next y

 

[Peter T]

Well Peter you have got me scratching my head on this one I noticed when I

ran my code on certain other charts sometimes it would return ('Sheet1')
and
other charts it would return as it should (Sheet1)

That's a different issue. I'll bet you never returned precisely 'Sheet1' but
you may well have returned say 'Sheet 1'. Spaces and some other characters
in the sheet name introduce the embracing apostrophes. Easily correctable,
replace the apostrophes with "", but that aside I still don't think your
routine is right.

Only thing I can figure is maybe difference in Excel versions being used
like I said I am using Excel 2000 perhaps newer versions handle things
differently ??

No, Excel 97 to Excel 2007 will work the same in this respect

If you use the routine I suggested you may find your head suffers less from
over scratching! Also it might cater for more scenarios than you may have
yet considered.

Regards,
Peter T

Well Peter you have got me scratching my head on this one I noticed when I
ran my code on certain other charts sometimes it would return ('Sheet1')
and
other charts it would return as it should (Sheet1) so I changed my code to
use .FormulaR1C1Local and that seems to work consistantly for both the
charts
that were returning normal (Sheet1) and the ones that were returning
('Sheet1') I don't know why you are getting the comma though I have run
several tests and I am not getting the preceding comma, like I said I did
have some issues with some charts returning with preceding and post single
quotes ('Sheet1') however the .FormulaR1C1local seems to do the trick for
eliminating that problem

I ran your test code though and here are the results for all the .formula
methods used plus I added the R1C1 too.

Sub test3()
Dim s As String
s = ActiveChart.SeriesCollection(1).Formula
Debug.Print "Formula", s
Debug.Print GetSheetName(s)
s = ActiveChart.SeriesCollection(1).FormulaLocal
Debug.Print "FormulaLocal", s
Debug.Print GetSheetName(s)
s = ActiveChart.SeriesCollection(1).FormulaR1C1Local
Debug.Print "FormulaR1C1Local", s
Debug.Print GetSheetName(s)
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

debug results

Formula =SERIES("20d MA Spot
Price",Sheet1!$A$2312:$A$5852,Sheet1!$E$2312:$E$5852,1)
Sheet1
FormulaLocal =SERIES("20d MA Spot
Price",Sheet1!$A$2312:$A$5852,Sheet1!$E$2312:$E$5852,1)
Sheet1
FormulaR1C1Local =SERIES("20d MA Spot
Price",Sheet1!R2312C1:R5852C1,Sheet1!R2312C5:R5852C5,1)
Sheet1

Only thing I can figure is maybe difference in Excel versions being used
like I said I am using Excel 2000 perhaps newer versions handle things
differently ??

Dan Thompson

That is strange when I use my code it returns the Sheet Name (String)
Fine
without the preceding comma I did notice that you are using
Activechart.Seriescollection(1).formula I am using .formulalocal

Sub test3()
Dim s As String
s = ActiveChart.SeriesCollection(1).Formula
Debug.Print "Formula", s
Debug.Print GetSheetName(s)
s = ActiveChart.SeriesCollection(1).FormulaLocal
Debug.Print "FormulaLocal", s
Debug.Print GetSheetName(s)
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

debug results

Formula =SERIES(,,Sheet1!$A$1:$A$3,1)
,Sheet1
FormulaLocal =SERIES(,,Sheet1!$A$1:$A$3,1)
,Sheet1

As you can see, a comma both ways

I am using Excel 2000 so I don't know if that has
somthing to do with it.

No, that wouldn't make a difference, but if the series name is linked to
a
cell it would (but can't be sure it always is).

I am not conserned at this time with
charts that are linked to data in different workbooks

The addin I mentioned also has a function to "resource" data from one
location to another, eg from an external wb to the chart wb. To cater for
most scenarios was amount of work.

Regards,
Peter T

Thanks Peter for your repsonse

That is strange when I use my code it returns the Sheet Name (String)
Fine
without the preceding comma I did notice that you are using
Activechart.Seriescollection(1).formula I am using .formulalocal I
don't
know
if that makes a differnce in the string returned having a preceding
comma
perhaps my math is off by 1 placement in the string but strangely
enough
my
code works on my system ? I am using Excel 2000 so I don't know if
that
has
somthing to do with it.

But yes you are right the objective of the macro is to remove all data
that
is not relevent to the active chart. I am not conserned at this time
with
charts that are linked to data in different workbooks however you bring
up
a
good point that I may need to incorporate into this code in the future.

I will try your code out and compare thanks for your input on this
today.

Dan Thompson

:

Your GetSheetName routine doesn't seem right, I get ",Sheet1" with the
preceding comma
The following if anything is slightly more complicated, but more
reliable.
It will also return the workbook name which might be relevant if the
data
and chart are not in same file.

Sub test()
Dim s As String
Dim sWSname As String, sFile As String

s = ActiveChart.SeriesCollection(1).Formula

If GetSourceSheet(s, sWSname, sFile) Then
MsgBox sWSname & vbCr & sFile
Else
MsgBox "source not determined" '(eg array or named formula)
End If

End Sub


Function GetSourceSheet(sFmla As String, sWSname, sFile As String) As
Boolean
Dim i As Long
Dim arr
Dim rng As Range

On Error Resume Next
arr = Split(Mid$(sFmla, 9, Len(sFmla) - 9), ",")
For i = UBound(arr) - 1 To 0 Step -1
Set rng = Range(arr(i))
If Not rng Is Nothing Then
sWSname = rng.Parent.Name
sFile = rng.Parent.Parent.Name
GetSourceSheet = True
Exit For
End If
Next
End Function


If I follow you are trying to remove all but essential chart data. I
have
an
addin that replaces source data in cells with source data in named
arrays
or
arrays in the series formula (latter subject relatively small data
limits
per series). IOW, can end up with a workbook with zero data in cells,
or
if
charts are chart-sheets zero worksheets. Contact me if interested (my
address is in the reply-to field).

Regards,
Peter T


message
Darn I thought that in this day and age SeriesCollection Object
would
alread
have a built in property or method for returning the Worksheetname
Guess I
will have to use my original method which does work just was hoping
for
a
shortcut

Here is the code I am using :

Sub GetSourceSheet()
SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a
spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is
not
a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate
End Sub

Function GetSheetName(ByVal ChartSeriesString As String) As String
Dim FChar As Integer, LChar As Integer
FChar = InStr(1, ChartSeriesString, ",") + 1
LChar = InStr(1, ChartSeriesString, "!") - 1
GetSheetName = Mid(ChartSeriesString, FChar, LChar - FChar + 1)
End Function

Keep in mind this code is only part of my entire program / macro
What the Entire Code does is remove all worksheets and data from a
workbook
that does not directly or indirectly belong to the Active Chart
and than alows the user to save the end result as a new workbook.
Thus
not
overiting the original workbook.

If you are interested here is the Entire Working Code for this Macro

Option Base 1
Sub AddChartSeriesDataFilterMenuButton()
'*******Add's A Menu Button to Excel to run Procedure "CSDF"
**********
Dim xlBar As CommandBar
Dim CustMnuBar As CommandBarButton
Set xlBar = Application.CommandBars("Chart Menu Bar")
Set CustMnuBar = xlBar.Controls.Add(Type:=msoControlButton,
Temporary:=False)
CustMnuBar.Caption = "ChartSeriesDataFilter"
CustMnuBar.Style = msoButtonCaption
CustMnuBar.Visible = True
With CustMnuBar
.OnAction = "CSDF"
End With
End Sub
'#############################################################################
' Chart Series Data Filter [MACRO]
'
'Import this module into a workbook with charts you wish to run it
on.
'Import this module into "Personal Workbook" to have access to it
from
any
Workbook.
'
'To run simply select a chart object, or chart Sheet and run the
macro.
'The macro when run, will delete all charts and data out of the
current
'workbook which are not relevent to the chart you selected to
isolate.
'#############################################################################
Sub CSDF()
Dim ChartIndex As Integer, NumOfSeries As Integer, X As Integer,
SheetCount
As Integer, y As Integer
Dim SeriesArray() As Variant, ColArray() As Variant
Dim ChartIsSheet As Boolean
Dim SheetName As String, SheetsToDel() As String, fileSaveName As
String

SheetName = ActiveSheet.Name

With ActiveChart
On Error Resume Next
ChartIsSheet = False
ChartIndex = .Parent.Index 'For chart objects within a
spreadsheet
If Err.Number = 438 Then 'Error Ocures if the chart selected is
not
a
chart object with in a spread sheet
ChartIndex = .Index 'For a chart that is it's own sheet(chart
sheet)
ChartIsSheet = True
End If
Err.Clear
NumOfSeries = .SeriesCollection.Count
End With

ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)

For X = 1 To NumOfSeries
SeriesArray(X) = ActiveChart.SeriesCollection(X).FormulaLocal
ColArray(X) = DataCol(SeriesArray(X))
Next X

SourceWrksheet = GetSheetName(SeriesArray(1))
Worksheets(SourceWrksheet).Activate

For X = 1 To NumOfSeries
Range(ColArray(X) & ":" & ColArray(X)).Select 'Selects source
data
column of a chart series
Selection.Interior.ColorIndex = 4 'Colors chart series data
column
bright green
Range(ColArray(X) & ":" &
ColArray(X)).Precedents.Columns.EntireColumn.Select 'The Precedents
command
Returns a Range object that represents all the precedents(links) of
a
cell
If Not Err.Number = 1004 Then 'Error 1004 is "No Cells Were
Found"
Meaning there are no Precedents(Links) for the cells.
Selection.Interior.ColorIndex = 35 'colors all
precendent(Linked)
cells light pastell green
End If
Next X

Err.Clear
Resume
GetNonGreenColPos

If ChartIsSheet = False Then
Sheets(SheetName).Activate
ActiveChart.Location Where:=xlLocationAsNewSheet,
Name:="NewChart"
ElseIf ChartIsSheet = True Then
Sheets(SheetName).Activate
Sheets(SheetName).Name = "NewChart"
End If

SheetCount = ActiveWorkbook.Sheets.Count

For y = 1 To SheetCount
If Not Sheets(y).Name = SourceWrksheet Then
If Not Sheets(y).Name = "NewChart" Then
t = t + 1
ReDim Preserve SheetsToDel(t)
SheetsToDel(t) = Sheets(y).Name
End If
End If
Next y

Application.DisplayAlerts = False ' prevent nags
For y = LBound(SheetsToDel) To UBound(SheetsToDel)
Sheets(SheetsToDel(y)).Delete
Next y

 

[Dan Thompson]

Well Peter you are right I tried my code with a worksheet name that has a
space ie.. "Sheet 1" and it fails because of the preceding and ending
apostrophes added by Excel when a worksheet has a space in the name

I have tried your code and indeed it does work more consistently than mine.
by the way I was unaware of the "Split" Function very nice I can think of
several other macros I have which could benefit from that one. And the use of
turning the split string into a range and using the "Parent " property to
extract the table name seems to be a much more reliable of way doing it.

I have a few questions regarding your code.

1) Why did you have your for next loop in the GetSourceSheet function
looping backwards threw your array and not forwards
2) Why did you use 4 Elements in your Array and then the use of the Exit for
which seems to be unnessicary

To Illistrate my questions below is my edited version of your function. If
there is some reason that you did your function the way you did which makes
it more reliable could you please explain it to me ?

Function GetSourceSheet(sFmla As String, sWSname, sFile As String) As Boolean
Dim i As Long
Dim arr
Dim rng As Range

On Error Resume Next
arr = Split(Mid$(sFmla, 9, Len(sFmla) - 9), ",")
For i = 0 To 1
Set rng = Range(arr(i))
If Not rng Is Nothing Then
sWSname = rng.Parent.Name
sFile = rng.Parent.Parent.Name
GetSourceSheet = True
End If
Next
End Function


Dan Thompson

 

[Peter T]

I have a few questions regarding your code.

1) Why did you have your for next loop in the GetSourceSheet function
looping backwards threw your array and not forwards
2) Why did you use 4 Elements in your Array and then the use of the Exit
for
which seems to be unnessicary

To start with the first part of your Q2,

=SERIES(Series-name,Catagory or X-Values,Y-Values, Order)
after doing the Split the 4 element array will hold the following *

Series-name
Catagory or X-Values
Y-Values
Index

Re Q1
Actually I started from the last but one element
For i = UBound(arr) - 1 To 0 Step -1

Although the Series-name can be linked to a cell, often it's not, ditto the
category values. The Y-Values is by far the most likely to be linked to
cells, so might as well start with that, then the next most likely the
X-Values.

Typically, 99+%, will get the source from the 3rd element, then bail out
with Exit For having got the range (don't continue the loop as you appear to
be doing). But if not, try a long shot and loop backwards just in case a
range can be made from either of the earlier elements.

Note, the source in the formula might not be a cell-ref, eg could be in
named range and that'll also get picked up this way. However data can be
data in the formula, eg {1,2,3}, or a named array. These of course are not
linked to cells at all.

You'd probably want to include some more checks to ensure you've got a valid
series formula beforehand.

* a bubble chart has an additional 5th section for the bubble sizes.

Regards,
Peter T

 

[Dan Thompson]

Well Peter your explanation of my questions make sense and are sound answers.
You seem very experienced with Excel and VBA

And your code is very clean I like that I myself am always trying to make my
programs more efficient and clean code. However I am probably still at a
novice to indermediate level with Excel & VBA so it is good to have responses
from someone like yourself.

To bad there was not a way of connecting with you more for future code
collaboration and idea sharing. Perhaps there is posability of further
communication threw email. If that is something that you would be ok with you
could let me know. My email is ([email protected])

Dan Thompson