I'll tell you what Tom If you got time to look at this code great if not
don't worry about it.
Anyhow if you do try to look at this then just paste the following code
into
an empty module. In order for the code to work you will need at least 2 or
more data columns which are being graphed on either a chart as an object
in a
spread sheet or a chart on it's own Sheet. (Best to use Line Chart for
test
perpouses)
now before I past the code I have flaged where the problem is ocuuring in
my
code just do a search with-in the code for the text *Problem Start*
Ok ready here's the code..
Option Base 1
'#############################################################################
' Chart Series Data Tracer [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 highlight the columns of data being used to
'draw the chart you selected.
'#############################################################################
Sub CSDT()
Dim ChartIndex As Integer, NumOfSeries As Integer, x As Integer
Dim SeriesArray() As Variant, ColArray() As Variant
With ActiveChart
On Error Resume Next
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)
End If
NumOfSeries = .SeriesCollection.Count
End With
ReDim SeriesArray(NumOfSeries)
ReDim ColArray(NumOfSeries)
For x = 1 To NumOfSeries
SeriesArray(x) = ActiveChart.SeriesCollection(x).Formula
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
End Sub
Sub GetNonGreenColPos()
Dim N As Integer, A As Integer, FirstOcurance As Integer, SecondOcurance
As
Integer
Dim CurCelAddress As String, NonGreenColArray() As String, MyRangeString
As
String
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
'*Problem Start*
MyRangeString = CreateRangeString(NonGreenColArray())
'If I use the CreateRangeString With a Small String it works
'If I use it with a large string than MyStringRange is "" Nothing
'and yet the next line returns a len of 1419 for MyStringRange
'Whats up with that ???
MsgBox (Len(MyRangeString))
Range(MyString).Select
End With
End Sub
Function CreateRangeString(ByRef NGCA() As String) As String
Dim R As Integer
Dim TestString As String
Dim FString As String, MyString As String
For R = 1 To UBound(NGCA())
If Not R = UBound(NGCA()) Then
MyString = NGCA(R) & ":" & NGCA(R) & ","
Else
MyString = NGCA(R) & ":" & NGCA(R)
End If
FString = FString + MyString
Next R
CreateRangeString = FString
End Function
Function GetSheetName(ByVal ChartSeriesString As String) As String
GetSheetName = Mid(ChartSeriesString, InStr(1, ChartSeriesString, "'") +
1,
InStr(InStr(1, ChartSeriesString, "'") + 1, ChartSeriesString, "'") -
(InStr(1, ChartSeriesString, "'") + 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
Tom Ogilvy said:
Thanks for the kind words - hopefully I can live up to them.
Perhaps a different approach:
are you looping and using some criteria to see if the column should be
deleted? for demonstration, I will check if the cell in row 1 has a
value
greater than 3:
Dim rng as Range, i as Long
for i = 100 to 1 step -1
if cells(1,i) > 3 then
if rng is nothing then
set rng = cells(1,i)
else
set rng = union(cells(1,i),rng)
end if
end if
Next
if not rng is nothing then
'rng.EntireColumn.Delete
rng.EntireColumn.Select
end if
you get the Idea.