Chip,
Thank you! Now it *almost* works. The syntax appears to be right, but
there's still a problem: it looks like the new "SelectionChange" event
procedure is being created, but a second SelectionChange shell code block is
also in the CodeModule below the one just added. It's there for two seconds
while the macro is running, then it crashes.
Here's the specific code you sent me, with just a minor change to allow me
to use a variables instead of hard-coded references:
With
ActiveWorkbook.VBProject.VBComponents(ActiveWorkbo ok.Worksheets("Contents").
CodeName).CodeModule
.InsertLines Line:=.CreateEventProc("SelectionChange", "Worksheet") + 1,
_
String:="If Not Intersect(Target, Range(""" & nextCell & """)) Is
Nothing Then" & vbCrLf & _
" Charts(""" & chartName & """).Activate" & vbCrLf & _
"End If"
End With
Don't see anything wrong? Me either. So here's the whole macro in case the
problem is somewhere else. BTW - Where can one find documentation of the
above?
Thank you very much,
Robert Stober
Sub CreateChart()
'
' CreateChart Macro
'
Dim cellContents As String
Dim sheetName As String
Dim pivotName As String
Dim chartName As String
Dim nextCell As String
Dim tName As String
Dim srcData As String
Dim shtCount As Integer
Dim SheetNames() As String
Dim count As Integer
Dim iCount As Integer
cellContents =
ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.count) .Cells(100, 1).Value
If cellContents = "True" Then
' prevent user interaction and turn off screen updating
Application.Interactive = False
Application.ScreenUpdating = False
Application.StatusBar = "Building Charts..."
' Put the names of the worksheets we need to create PivotTables
' and PivotCharts for into the SheetNames array.
count = 1
iCount = 1
' Look at each sheet in the Sheets collection
For Each shtNext In Sheets
shtType = TypeName(shtNext)
' We want worksheets where the value of cell 100, 1 is NOT
"True"
If shtType = "Worksheet" Then
If shtNext.Cells(100, 1).Value < "True" Then
ReDim Preserve SheetNames(1 To iCount)
SheetNames(iCount) = Sheets(count).Name
iCount = iCount + 1
Else
shtNext.Cells(100, 1).Value = ""
End If
End If
count = count + 1
Next shtNext
' Now that we have the relevant worksheets in SheetNames, lets
create
' PivotTables and Charts for each of them
For shtCount = 1 To UBound(SheetNames)
nextCell = "B" & shtCount
sheetName = SheetNames(shtCount)
pivotName = "PivotTable." & shtCount
chartName = "pc." & sheetName
tName = "pt." & sheetName
srcData = sheetName & "!$A:$F"
Sheets(sheetName).Select
' we need to dynamically create the contents page from here
Sheets("Contents").Range(nextCell).Value = chartName
With
ActiveWorkbook.VBProject.VBComponents(ActiveWorkbo ok.Worksheets("Contents").
CodeName).CodeModule
.InsertLines Line:=.CreateEventProc("SelectionChange",
"Worksheet") + 1, _
String:="If Not Intersect(Target, Range(""" & nextCell & """))
Is Nothing Then" & vbCrLf & _
" Charts(""" & chartName & """).Activate" & vbCrLf & _
"End If"
End With
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatab ase, SourceData:=
_
srcData).CreatePivotTable TableDestination:="",
tableName:=pivotName
ActiveSheet.PivotTableWizard TableDestination:=ActiveSheet.Cells(3,
1)
ActiveSheet.Cells(3, 1).Select
ActiveSheet.PivotTables(pivotName).SmallGrid = False
ActiveSheet.Name = tName
Charts.Add
ActiveChart.SetSourceData Source:=Sheets(tName).Range("A3")
ActiveChart.Location Whe=xlLocationAsNewSheet
ActiveChart.Name = chartName
Sheets(tName).Select
With ActiveSheet.PivotTables(pivotName).PivotFields("Da te")
.Orientation = xlRowField
.Position = 1
End With
With ActiveSheet.PivotTables(pivotName).PivotFields("Us ed")
.Orientation = xlDataField
.Position = 1
End With
ActiveSheet.PivotTables(pivotName).PivotFields("Co unt of
Used").Function = _
xlSum
Charts(chartName).Select
With ActiveChart.PivotLayout.PivotFields("Date")
.PivotItems("(blank)").Visible = False
End With
Next
'ActiveWorkbook.Sheets.Add
'ActiveSheet.Name = "Start"
' allow interaction and turn on screen updating
Application.StatusBar = "Done Building Charts"
Application.Interactive = True
Application.ScreenUpdating = True
End If
End Sub
"Chip Pearson" wrote in message
...
Robert,
Try the following code. Watch out for line breaks.
With ActiveWorkbook.VBProject.VBComponents( _
ActiveWorkbook.Worksheets("Contents").CodeName).Co deModule
.InsertLines Line:=.CreateEventProc("SelectionChange", "Worksheet") +
1,
_
String:= _
"If Not Intersect(Target, Range(""B2"")) Is Nothing Then" & vbCrLf
&
_
" Charts(""Chart1"").Activate" & vbCrLf & _
"End If"
End With
--
Cordially,
Chip Pearson
Microsoft MVP - Excel
www.cpearson.com
"Robert Stober" wrote in message
...
Hi,
I'm using Jon Peltier's workaround (to Excel's inability to create
hyperlinks to chart sheets) to create a table of contents. The following
event procedure is placed in the code module for the "contents" sheet.
It
activates the chart sheet when the user selects the linked cell:
' Thank you Jon!
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Not Intersect(Target, Range("B2")) Is Nothing Then
Charts("Chart1").Activate
End If
End Sub
This works fine, except that I need to create it on the fly from within
a
macro. Here's what I've got so far:
ActiveWorkbook.VBProject.VBComponents("Contents"). CodeModule.InsertLines
_
ActiveWorkbook.VBProject.VBComponents("Contents"). CodeModule.CreateEventProc
( _
"SelectionChange", "Worksheet") + 1, _
"MsgBox Hello"
Where "Contents" is the name of the worksheet where I want the event
procedure. The actual code I want to invoke inside the event procedure
isn't
really "MsgBox Hello", but I can't even get this simple code to work. I
get
"subscript out of range"....
For those of you who want to know more, the code I really want instead
of
MsgBox is:
"If Not Intersect(Target, Range("B2")) Is Nothing Then
Charts("Chart1").Activate
End If"
I know this is a hard one. Can anyone provide any suggestions?
Thank you,
Robert Stober