TOC not in alphabetic order

K

Klemen25

In David McRitchies (http://www.mvps.org/dmcritchie/excel/
buildtoc.htm ) TOC page there is a great macro for building TOC.
But this table sorts the sheets in alphabetic order. Is there a way to
change the macro, so it will sort the sheets according to the way they
are sorted in the workbook?


Sub BuildTOC()
'listed from active cell down 7-cols -- DMcRitchie 1999-08-14
2000-09-05
Dim iSheet As Long, iBefore As Long
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Long
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
mg = ""
CRLF = Chr(10) 'Actually just CR
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 +
ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" &
CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not
$$TOC" & CRLF
If mg <> "" Then
mg = "Warning BuildTOC will destructively rewrite the selected
area" _
& CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
& "the affected area will be rewritten, or" & CRLF & _
"Press CANCEL to check area then reinvoke this macro (BuildTOC)"
Application.ScreenUpdating = True 'make range visible
Reply = MsgBox(mg, vbOKCancel, "Create TOC for " &
ActiveWorkbook.Sheets.Count _
& " items in workbook" & Chr(10) & "revised will now occupy up
to 10 columns")
Application.ScreenUpdating = False
If Reply <> 1 Then GoTo AbortCode
End If
rg.Clear 'Clear out any previous hyperlinks, fonts, etc in the
area
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
'hypName = "'" & Sheets(csht).Name
' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace
not in XL97
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8.0 Then
'-- use next line for XL95
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
'XL95
Else
'-- Only for XL97, XL98, XL2000 -- will create hyperlink &
codename
Cells(cRow - 1 + cSht, cCol + 2) = "'" &
Sheets(cSht).CodeName

'--- excel is not handling lots of objects well ---
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht,
cCol), _
' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
'--- so will use the HYPERLINK formula instead ---
'--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
Else
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
End If
Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
' -- activate next line to include content of cell A1 for each
sheet
' Cells(cRow - 1 + csht, cCol + 3) =
Sheets(Sheets(csht).Name).Range("A1").Value
On Error Resume Next
Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea
'.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 7) =
Sheets(cSht).PageSetup.PrintArea
If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
On Error GoTo 0
Next cSht

'Now sort the results: 2. Type(D), 1. Name (A), 3. module(unsorted)
rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending,
Key2:=rg.Cells(1, 1) _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1,
MatchCase:=False, _
Orientation:=xlTopToBottom
rg.Columns.AutoFit
rg.Select 'optional
'if cells above range are blank want these headers
' Worksheet, Type, codename
If cRow > 1 Then
If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) &
Cells(cRow - 1, cCol + 2)) Then
Cells(cRow - 1, cCol) = "Worksheet"
Cells(cRow - 1, cCol + 1) = "Type"
Cells(cRow - 1, cCol + 2) = "CodeName"
Cells(cRow - 1, cCol + 3) = "[opt.]"
Cells(cRow - 1, cCol + 4) = "Lastcell"
Cells(cRow - 1, cCol + 5) = "cells"
Cells(cRow - 1, cCol + 6) = "ScrollArea"
Cells(cRow - 1, cCol + 7) = "PrintArea"
End If
End If
Application.ScreenUpdating = True
Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
"Would you like the tabs in workbook also sorted", _
vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
& " tabs in workbook")
Application.ScreenUpdating = False
If Reply = 1 Then SortALLSheets 'Invoke macro to Sort Sheet Tabs
Sheets(sSheetName).Activate
AbortCode:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub BuildTOC_A3()
Cells(3, 1).Select
BuildTOC
End Sub
 
D

Dave Peterson

David goes out of his way to sort the list in alphabetical order. Without that
extra step, the list will be in order that you want.

Look for rg.sort and comment that line.

Then test it to see if it works the way you want.
In David McRitchies (http://www.mvps.org/dmcritchie/excel/
buildtoc.htm ) TOC page there is a great macro for building TOC.
But this table sorts the sheets in alphabetic order. Is there a way to
change the macro, so it will sort the sheets according to the way they
are sorted in the workbook?

Sub BuildTOC()
'listed from active cell down 7-cols -- DMcRitchie 1999-08-14
2000-09-05
Dim iSheet As Long, iBefore As Long
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Long
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
mg = ""
CRLF = Chr(10) 'Actually just CR
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 +
ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" &
CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not
$$TOC" & CRLF
If mg <> "" Then
mg = "Warning BuildTOC will destructively rewrite the selected
area" _
& CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
& "the affected area will be rewritten, or" & CRLF & _
"Press CANCEL to check area then reinvoke this macro (BuildTOC)"
Application.ScreenUpdating = True 'make range visible
Reply = MsgBox(mg, vbOKCancel, "Create TOC for " &
ActiveWorkbook.Sheets.Count _
& " items in workbook" & Chr(10) & "revised will now occupy up
to 10 columns")
Application.ScreenUpdating = False
If Reply <> 1 Then GoTo AbortCode
End If
rg.Clear 'Clear out any previous hyperlinks, fonts, etc in the
area
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
'hypName = "'" & Sheets(csht).Name
' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace
not in XL97
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8.0 Then
'-- use next line for XL95
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
'XL95
Else
'-- Only for XL97, XL98, XL2000 -- will create hyperlink &
codename
Cells(cRow - 1 + cSht, cCol + 2) = "'" &
Sheets(cSht).CodeName

'--- excel is not handling lots of objects well ---
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht,
cCol), _
' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
'--- so will use the HYPERLINK formula instead ---
'--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
Else
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
End If
Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
' -- activate next line to include content of cell A1 for each
sheet
' Cells(cRow - 1 + csht, cCol + 3) =
Sheets(Sheets(csht).Name).Range("A1").Value
On Error Resume Next
Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea
'.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 7) =
Sheets(cSht).PageSetup.PrintArea
If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
On Error GoTo 0
Next cSht

'Now sort the results: 2. Type(D), 1. Name (A), 3. module(unsorted)
rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending,
Key2:=rg.Cells(1, 1) _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1,
MatchCase:=False, _
Orientation:=xlTopToBottom
rg.Columns.AutoFit
rg.Select 'optional
'if cells above range are blank want these headers
' Worksheet, Type, codename
If cRow > 1 Then
If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) &
Cells(cRow - 1, cCol + 2)) Then
Cells(cRow - 1, cCol) = "Worksheet"
Cells(cRow - 1, cCol + 1) = "Type"
Cells(cRow - 1, cCol + 2) = "CodeName"
Cells(cRow - 1, cCol + 3) = "[opt.]"
Cells(cRow - 1, cCol + 4) = "Lastcell"
Cells(cRow - 1, cCol + 5) = "cells"
Cells(cRow - 1, cCol + 6) = "ScrollArea"
Cells(cRow - 1, cCol + 7) = "PrintArea"
End If
End If
Application.ScreenUpdating = True
Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
"Would you like the tabs in workbook also sorted", _
vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
& " tabs in workbook")
Application.ScreenUpdating = False
If Reply = 1 Then SortALLSheets 'Invoke macro to Sort Sheet Tabs
Sheets(sSheetName).Activate
AbortCode:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub BuildTOC_A3()
Cells(3, 1).Select
BuildTOC
End Sub
Click to expand...
 
D

Don Guillett

Will this do? It just puts the name of each sheet in col A.

Sub simpletoc()
For i = 1 To Worksheets.Count
Cells(i, 1) = Sheets(i).Name
Next
End Sub

--
Don Guillett
SalesAid Software
(e-mail address removed)
Klemen25 said:
In David McRitchies (http://www.mvps.org/dmcritchie/excel/
buildtoc.htm ) TOC page there is a great macro for building TOC.
But this table sorts the sheets in alphabetic order. Is there a way to
change the macro, so it will sort the sheets according to the way they
are sorted in the workbook?


Sub BuildTOC()
'listed from active cell down 7-cols -- DMcRitchie 1999-08-14
2000-09-05
Dim iSheet As Long, iBefore As Long
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Long
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
mg = ""
CRLF = Chr(10) 'Actually just CR
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 +
ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" &
CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not
$$TOC" & CRLF
If mg <> "" Then
mg = "Warning BuildTOC will destructively rewrite the selected
area" _
& CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
& "the affected area will be rewritten, or" & CRLF & _
"Press CANCEL to check area then reinvoke this macro (BuildTOC)"
Application.ScreenUpdating = True 'make range visible
Reply = MsgBox(mg, vbOKCancel, "Create TOC for " &
ActiveWorkbook.Sheets.Count _
& " items in workbook" & Chr(10) & "revised will now occupy up
to 10 columns")
Application.ScreenUpdating = False
If Reply <> 1 Then GoTo AbortCode
End If
rg.Clear 'Clear out any previous hyperlinks, fonts, etc in the
area
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
'hypName = "'" & Sheets(csht).Name
' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace
not in XL97
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8.0 Then
'-- use next line for XL95
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
'XL95
Else
'-- Only for XL97, XL98, XL2000 -- will create hyperlink &
codename
Cells(cRow - 1 + cSht, cCol + 2) = "'" &
Sheets(cSht).CodeName

'--- excel is not handling lots of objects well ---
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht,
cCol), _
' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
'--- so will use the HYPERLINK formula instead ---
'--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
Else
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
End If
Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
' -- activate next line to include content of cell A1 for each
sheet
' Cells(cRow - 1 + csht, cCol + 3) =
Sheets(Sheets(csht).Name).Range("A1").Value
On Error Resume Next
Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea
'.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 7) =
Sheets(cSht).PageSetup.PrintArea
If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
On Error GoTo 0
Next cSht

'Now sort the results: 2. Type(D), 1. Name (A), 3. module(unsorted)
rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending,
Key2:=rg.Cells(1, 1) _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1,
MatchCase:=False, _
Orientation:=xlTopToBottom
rg.Columns.AutoFit
rg.Select 'optional
'if cells above range are blank want these headers
' Worksheet, Type, codename
If cRow > 1 Then
If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) &
Cells(cRow - 1, cCol + 2)) Then
Cells(cRow - 1, cCol) = "Worksheet"
Cells(cRow - 1, cCol + 1) = "Type"
Cells(cRow - 1, cCol + 2) = "CodeName"
Cells(cRow - 1, cCol + 3) = "[opt.]"
Cells(cRow - 1, cCol + 4) = "Lastcell"
Cells(cRow - 1, cCol + 5) = "cells"
Cells(cRow - 1, cCol + 6) = "ScrollArea"
Cells(cRow - 1, cCol + 7) = "PrintArea"
End If
End If
Application.ScreenUpdating = True
Reply = MsgBox("Table of Contents created." & CRLF & CRLF & _
"Would you like the tabs in workbook also sorted", _
vbOKCancel, "Option to Sort " & ActiveWorkbook.Sheets.Count _
& " tabs in workbook")
Application.ScreenUpdating = False
If Reply = 1 Then SortALLSheets 'Invoke macro to Sort Sheet Tabs
Sheets(sSheetName).Activate
AbortCode:
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
End Sub
Sub BuildTOC_A3()
Cells(3, 1).Select
BuildTOC
End Sub
Click to expand...
 
K

Klemen25

Actually it is not ok, as I would like to have hyperlinks behind, not
just TOC.
I used David's advice, played with the code (dont understand it) but
somehow I got to this. It displays TOC with hyperlinks without
alphabetic sorting. There is perhaps still some code not needed- but
my main goal was that it works!
Thanks to all and specially to David McRitchies- it is his code!


Sub BuildTOC()
'listed from active cell down 7-cols -- DMcRitchie 1999-08-14
2000-09-05
Dim iSheet As Long, iBefore As Long
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Long
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
mg = ""
CRLF = Chr(10) 'Actually just CR
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 +
ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" &
CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not
$$TOC" & CRLF
If mg <> "" Then
mg = "Warning BuildTOC will destructively rewrite the selected
area" _
& CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
& "the affected area will be rewritten, or" & CRLF & _
"Press CANCEL to check area then reinvoke this macro (BuildTOC)"
Application.ScreenUpdating = True 'make range visible
Reply = MsgBox(mg, vbOKCancel, "Create TOC for " &
ActiveWorkbook.Sheets.Count _
& " items in workbook" & Chr(10) & "revised will now occupy up
to 10 columns")
Application.ScreenUpdating = False
End If
rg.Clear 'Clear out any previous hyperlinks, fonts, etc in the
area
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
'hypName = "'" & Sheets(csht).Name
' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace
not in XL97
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8# Then
'-- use next line for XL95
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
'XL95
Else
'-- Only for XL97, XL98, XL2000 -- will create hyperlink &
codename
Cells(cRow - 1 + cSht, cCol + 2) = "'" &
Sheets(cSht).CodeName

'--- excel is not handling lots of objects well ---
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht,
cCol), _
' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
'--- so will use the HYPERLINK formula instead ---
'--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
Else
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
End If
Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
' -- activate next line to include content of cell A1 for each
sheet
' Cells(cRow - 1 + csht, cCol + 3) =
Sheets(Sheets(csht).Name).Range("A1").Value
On Error Resume Next
Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea
'.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 7) =
Sheets(cSht).PageSetup.PrintArea
If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
On Error GoTo 0
Next cSht
rg.Select 'optional
'if cells above range are blank want these headers
' Worksheet, Type, codename
If cRow > 1 Then
If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) &
Cells(cRow - 1, cCol + 2)) Then
Cells(cRow - 1, cCol) = "Worksheet"
Cells(cRow - 1, cCol + 1) = "Type"
Cells(cRow - 1, cCol + 2) = "CodeName"
Cells(cRow - 1, cCol + 3) = "[opt.]"
Cells(cRow - 1, cCol + 4) = "Lastcell"
Cells(cRow - 1, cCol + 5) = "cells"
Cells(cRow - 1, cCol + 6) = "ScrollArea"
Cells(cRow - 1, cCol + 7) = "PrintArea"
End If
End If

End Sub
 
D

Dave Peterson

The only line of code (one logical line spread over multiple physical lines) is
this:

rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending, Key2:=rg.Cells(1, 1) _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

If you still have the original code (or copy from David McRitchie's site), you
can just stick an apostrophe in front of the rg.sort ...

'rg.Sort Key1:=rg.Cells(1, 2), Order1:=xlDescending, Key2:=rg.Cells(1, 1) _
, Order2:=xlAscending, Header:=xlNo, OrderCustom:=1, MatchCase:=False, _
Orientation:=xlTopToBottom

This makes the line a comment. Excel won't use it, but if you ever decide that
you want it sorted, you can just remove that apostrophe and you're set.
Actually it is not ok, as I would like to have hyperlinks behind, not
just TOC.
I used David's advice, played with the code (dont understand it) but
somehow I got to this. It displays TOC with hyperlinks without
alphabetic sorting. There is perhaps still some code not needed- but
my main goal was that it works!
Thanks to all and specially to David McRitchies- it is his code!

Sub BuildTOC()
'listed from active cell down 7-cols -- DMcRitchie 1999-08-14
2000-09-05
Dim iSheet As Long, iBefore As Long
Dim sSheetName As String, sActiveCell As String
Dim cRow As Long, cCol As Long, cSht As Long
Dim lastcell
Dim qSht As String
Dim mg As String
Dim rg As Range
Dim CRLF As String
Dim Reply As Variant
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
cRow = ActiveCell.Row
cCol = ActiveCell.Column
sSheetName = UCase(ActiveSheet.Name)
sActiveCell = UCase(ActiveCell.Value)
mg = ""
CRLF = Chr(10) 'Actually just CR
Set rg = Range(Cells(cRow, cCol), Cells(cRow - 1 +
ActiveWorkbook.Sheets.Count, cCol + 7))
rg.Select
If sSheetName <> "$$TOC" Then mg = mg & "Sheetname is not $$TOC" &
CRLF
If sActiveCell <> "$$TOC" Then mg = mg & "Selected cell value is not
$$TOC" & CRLF
If mg <> "" Then
mg = "Warning BuildTOC will destructively rewrite the selected
area" _
& CRLF & CRLF & mg & CRLF & "Press OK to proceed, " _
& "the affected area will be rewritten, or" & CRLF & _
"Press CANCEL to check area then reinvoke this macro (BuildTOC)"
Application.ScreenUpdating = True 'make range visible
Reply = MsgBox(mg, vbOKCancel, "Create TOC for " &
ActiveWorkbook.Sheets.Count _
& " items in workbook" & Chr(10) & "revised will now occupy up
to 10 columns")
Application.ScreenUpdating = False
End If
rg.Clear 'Clear out any previous hyperlinks, fonts, etc in the
area
For cSht = 1 To ActiveWorkbook.Sheets.Count
Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
If TypeName(Sheets(cSht)) = "Worksheet" Then
'hypName = "'" & Sheets(csht).Name
' qSht = Replace(Sheets(cSht).Name, """", """""") -- replace
not in XL97
qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
If CDbl(Application.Version) < 8# Then
'-- use next line for XL95
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
'XL95
Else
'-- Only for XL97, XL98, XL2000 -- will create hyperlink &
codename
Cells(cRow - 1 + cSht, cCol + 2) = "'" &
Sheets(cSht).CodeName

'--- excel is not handling lots of objects well ---
'ActiveSheet.Hyperlinks.Add Anchor:=Cells(cRow - 1 + cSht,
cCol), _
' Address:="", SubAddress:="'" & Sheets(cSht).Name & "'!A1"
'--- so will use the HYPERLINK formula instead ---
'--- =HYPERLINK("[VLOOKUP.XLS]'$$TOC'!A1","$$TOC")
ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
"=hyperlink(""[" & ActiveWorkbook.Name _
& "]'" & qSht & "'!A1"",""" & qSht & """)"
End If
Else
Cells(cRow - 1 + cSht, cCol + 2) = "'" & Sheets(cSht).Name
End If
Cells(cRow - 1 + cSht, cCol + 1) = TypeName(Sheets(cSht))
' -- activate next line to include content of cell A1 for each
sheet
' Cells(cRow - 1 + csht, cCol + 3) =
Sheets(Sheets(csht).Name).Range("A1").Value
On Error Resume Next
Cells(cRow - 1 + cSht, cCol + 6) = Sheets(cSht).ScrollArea
'.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 7) =
Sheets(cSht).PageSetup.PrintArea
If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
Set lastcell = Sheets(cSht).Cells.SpecialCells(xlLastCell)
Cells(cRow - 1 + cSht, cCol + 4) = lastcell.Address(0, 0)
Cells(cRow - 1 + cSht, cCol + 5) = lastcell.Column * lastcell.Row
byp7: 'xxx
On Error GoTo 0
Next cSht
rg.Select 'optional
'if cells above range are blank want these headers
' Worksheet, Type, codename
If cRow > 1 Then
If "" = Trim(Cells(cRow - 1, cCol) & Cells(cRow - 1, cCol + 1) &
Cells(cRow - 1, cCol + 2)) Then
Cells(cRow - 1, cCol) = "Worksheet"
Cells(cRow - 1, cCol + 1) = "Type"
Cells(cRow - 1, cCol + 2) = "CodeName"
Cells(cRow - 1, cCol + 3) = "[opt.]"
Cells(cRow - 1, cCol + 4) = "Lastcell"
Cells(cRow - 1, cCol + 5) = "cells"
Cells(cRow - 1, cCol + 6) = "ScrollArea"
Cells(cRow - 1, cCol + 7) = "PrintArea"
End If
End If

End Sub
Click to expand...
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

mailing labels. . .but first, name list 1
Hyperlink Code will not work in XL2002 2
VBA Macro - Copying specific data to different sheets in a workbookand linking the InputBox to a com 7
VBA code does not work when file open directly in browser 1
[Q] How to sort tabs in order of CodeName 2
Loop to copy paste rows base on table arrays 0
Loop returns only one value, does not loop & an assignment to columnhow-to problem. 26
Array with many cells from a row but not in order or together 11

Top