EricM
03-23-2005, 08:19 PM
I get a error if the TOC already exists. I will paste the error but can someone tell me what is wrong. I believe I might have even found this here but when I did a search to find it nothing.
Sub CreateTOC()
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet, _
ct As Chart, _
shtName As String, _
nrow As Long, _
tmpCount As Long, _
i As Long, _
numCharts As Long
nrow = 3
i = 1
numCharts = ActiveWorkbook.Charts.Count
On Error GoTo hasSheet
Sheets("TOC").Activate
If MsgBox("You already have a Table of Contents page. Would you like to overwrite it?", _
vbYesNo + vbQuestion, "Replace TOC page?") = vbYes Then GoTo createNew
Exit Sub
hasSheet:
Sheets.Add Before:=Sheets(1)
GoTo hasNew
createNew:
Sheets("TOC").Delete
GoTo hasSheet
hasNew:
tmpCount = ActiveWorkbook.Charts.Count
If tmpCount > 0 Then tmpCount = 1
ActiveSheet.Name = "TOC"
With Sheets("TOC")
'.Cells.SetBackgroundPicture "c:\index.jpg"
' Worksheets(1).SetBackgroundPicture "c:\index.jpg"
.Cells.Interior.ColorIndex = RGB(255, 102, 0)
.Range("B2").Value = "Table of Contents"
.Range("B2").Font.Bold = True
.Range("B2").Font.Name = "Arial"
.Range("B2").Font.Size = "24"
'.Range("B2").Font.Color = RGB(255, 102, 0)
.Range("B4").Select
End With
For Each ws In ActiveWorkbook.Worksheets
nrow = nrow + 1
With ws
shtName = ws.Name
Sheets("TOC").Range("B" & nrow).Value = nrow - 3
Sheets("TOC").Range("C" & nrow).Hyperlinks.Add _
Anchor:=Sheets("TOC").Range("C" & nrow), Address:="#'" & _
shtName & "'!A1", TextToDisplay:=shtName
Sheets("TOC").Range("C" & nrow).HorizontalAlignment = xlLeft
End With
Next ws
If numCharts <> 0 Then
For Each ct In ActiveWorkbook.Charts
nrow = nrow + 1
shtName = ct.Name
Sheets("TOC").Range("B" & nrow).Value = nrow - 3
Sheets("TOC").Range("C" & nrow).Value = shtName
Sheets("TOC").Range("C" & nrow).HorizontalAlignment = xlLeft
Next ct
End If
With Sheets("TOC").Range("B2:G2")
.MergeCells = True
.HorizontalAlignment = xlLeft
End With
With Sheets("TOC")
.Range("C:C").EntireColumn.AutoFit
.Activate
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done!" & vbNewLine & vbNewLine & "Please note: " & _
"Charts are listed after regular " & vbCrLf & _
"worksheets and will not have hyperlinks.", vbInformation, "Complete!"
End Sub
Runtime error 1004
Cannot rename a sheet to the name of another sheet....
well I fixed a error I created when i did the color index and for some reason it fixed the error. I guess what was happening is that I was getting one error created by another and that is why I could not figure out the rename issue. So solving that can someone tell me how to make this red since RGB doesnt seem to work.
.Cells.Interior.ColorIndex = RGB(255, 102, 0)
Sub CreateTOC()
If ActiveWorkbook Is Nothing Then
MsgBox "You must have a workbook open first!", vbInformation, "No Open Book"
Exit Sub
End If
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim ws As Worksheet, _
ct As Chart, _
shtName As String, _
nrow As Long, _
tmpCount As Long, _
i As Long, _
numCharts As Long
nrow = 3
i = 1
numCharts = ActiveWorkbook.Charts.Count
On Error GoTo hasSheet
Sheets("TOC").Activate
If MsgBox("You already have a Table of Contents page. Would you like to overwrite it?", _
vbYesNo + vbQuestion, "Replace TOC page?") = vbYes Then GoTo createNew
Exit Sub
hasSheet:
Sheets.Add Before:=Sheets(1)
GoTo hasNew
createNew:
Sheets("TOC").Delete
GoTo hasSheet
hasNew:
tmpCount = ActiveWorkbook.Charts.Count
If tmpCount > 0 Then tmpCount = 1
ActiveSheet.Name = "TOC"
With Sheets("TOC")
'.Cells.SetBackgroundPicture "c:\index.jpg"
' Worksheets(1).SetBackgroundPicture "c:\index.jpg"
.Cells.Interior.ColorIndex = RGB(255, 102, 0)
.Range("B2").Value = "Table of Contents"
.Range("B2").Font.Bold = True
.Range("B2").Font.Name = "Arial"
.Range("B2").Font.Size = "24"
'.Range("B2").Font.Color = RGB(255, 102, 0)
.Range("B4").Select
End With
For Each ws In ActiveWorkbook.Worksheets
nrow = nrow + 1
With ws
shtName = ws.Name
Sheets("TOC").Range("B" & nrow).Value = nrow - 3
Sheets("TOC").Range("C" & nrow).Hyperlinks.Add _
Anchor:=Sheets("TOC").Range("C" & nrow), Address:="#'" & _
shtName & "'!A1", TextToDisplay:=shtName
Sheets("TOC").Range("C" & nrow).HorizontalAlignment = xlLeft
End With
Next ws
If numCharts <> 0 Then
For Each ct In ActiveWorkbook.Charts
nrow = nrow + 1
shtName = ct.Name
Sheets("TOC").Range("B" & nrow).Value = nrow - 3
Sheets("TOC").Range("C" & nrow).Value = shtName
Sheets("TOC").Range("C" & nrow).HorizontalAlignment = xlLeft
Next ct
End If
With Sheets("TOC").Range("B2:G2")
.MergeCells = True
.HorizontalAlignment = xlLeft
End With
With Sheets("TOC")
.Range("C:C").EntireColumn.AutoFit
.Activate
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
MsgBox "Done!" & vbNewLine & vbNewLine & "Please note: " & _
"Charts are listed after regular " & vbCrLf & _
"worksheets and will not have hyperlinks.", vbInformation, "Complete!"
End Sub
Runtime error 1004
Cannot rename a sheet to the name of another sheet....
well I fixed a error I created when i did the color index and for some reason it fixed the error. I guess what was happening is that I was getting one error created by another and that is why I could not figure out the rename issue. So solving that can someone tell me how to make this red since RGB doesnt seem to work.
.Cells.Interior.ColorIndex = RGB(255, 102, 0)