• Hi All

    Please note that at the Chandoo.org Forums there is Zero Tolerance to Spam

    Post Spam and you Will Be Deleted as a User

    Hui...

  • When starting a new post, to receive a quicker and more targeted answer, Please include a sample file in the initial post.

How to create a Table of Contents for many sheets in the same workbook

F

Feeling Like a Newbie :/

New Member
Hi,

Im trying to create a ToC on sheet 1 for all the other 50 or so tabs/sheets within the same workbook.

Is there function in Excel or a macro for this? I know MS Word does it perfectly. But cant find it in MS Excel.
 
A1 will have a heading "Table of Contents"
A2 the heading for all the tabs
B2 the heading for a cell on each tab.
A3 and B3 ...until all tabs are done, will hold the information for each tab.

upload_2014-8-1_10-40-40.png
 
I did find this through google, it does almost what I need and I've adjusted the code a bit to try to get it to do what I want...but I dont really know macros and am finding it difficult to alter the code and still have it work correctly.

----------------------------------------------------------------------------
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
  'Range("A3").Select
  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 + 20, cCol + 3))
  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, & 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# 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("B5").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
 
Last edited by a moderator:
Hi ,

If you can upload a sample workbook with one sheet tab , with the headers in place , then the code you have posted can be changed to suit your sheet layout. I hope that in your workbook , all sheet tabs have the same structure.

Narayan
 
Thanks for your help Narayan, here is a simple copy of the workbook that I'm trying to get up and running.

the other thing I am trying to do is have the code exclude the TOC sheet within the TOC list.
 

Attachments

  • Form - Testing TOC.xlsm
    65.1 KB · Views: 3
Hi ,

See your file now. If you add more sheets to your workbook , and rerun the macro , your TOC should be recreated.

I have only changed a few things in the macro , and there are a lot of lines of code that have been commented out , which may not be needed ; if everything works OK , then later on , you can probably delete all those lines.

Narayan
 

Attachments

  • Form - Testing TOC.xlsm
    65 KB · Views: 9
That's fantastic!!! thank you so much! that works exactly how I need it to :)
the commented out lines ....thats because the code wasnt mine and I'm relatively new to the Macro thingy and didnt know what each line did, so commenting them out was the safest way to not get that line to be seen.
 
Narayan, is this the line that excludes some sheets from the TOC list?

If sSheetName <> "TOC" Then mg = mg & "Sheetname is not TOC" & CRLF

and if so, can I just add other sheet names in like the template that wasnt in the excel that I gave you.

If sSheetName <> "TOC" Then mg = mg & "Sheetname is not TOC" "Sheetname is not TEMPLATE" & CRLF
 
Code for anyone else :)
Code: 
Option Explicit

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)
  Set rg = Range(Cells(cRow, cCol), Cells(cRow + ActiveWorkbook.Sheets.Count - 1, cCol + 1))
  rg.Select
  If sSheetName <> "TOC" Then mg = mg & "Sheetname is not TOC" & CRLF
     
  Application.ScreenUpdating = True  'make range visible
  Reply = MsgBox(mg, vbOKCancel, "Create TOC for " & ActiveWorkbook.Sheets.Count _
                 & " items in workbook" & Chr(10))
  Application.ScreenUpdating = False
  If Reply <> 1 Then GoTo AbortCode
  rg.Clear      'Clear out any previous hyperlinks, fonts, etc in the area
  For cSht = 1 To ActiveWorkbook.Sheets.Count
     If TypeName(Sheets(cSht)) <> "Worksheet" Then GoTo byp7
     
     If Sheets(cSht).Name = "TOC" Then GoTo byp7
       
     Cells(cRow - 1 + cSht, cCol) = "'" & Sheets(cSht).Name
           qSht = Application.Substitute(Sheets(cSht).Name, """", """""")
           If CDbl(Application.Version) < 8# Then
           Else
              ActiveSheet.Cells(cRow - 1 + cSht, cCol).Formula = _
              "=hyperlink(""[" & ActiveWorkbook.Name _
              & "]'" & qSht & "'!A1"",""" & qSht & """)"
           End If
     Cells(cRow - 1 + cSht, cCol + 1) = Sheets(Sheets(cSht).Name).Range("B5").Value
byp7:
  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

AbortCode:
  Application.ScreenUpdating = True
  Application.Calculation = xlCalculationAutomatic
  Range("A3").Select
End Sub

Sub BuildTOC_A3()
    ThisWorkbook.Worksheets("TOC").Activate
    Cells(3, 1).Select
    BuildTOC
End Sub
 
Hi ,

See this file ; there is a line of code where you can enter the names of those sheets you wish to exclude from the TOC.

Narayan
 

Attachments

  • Form - Testing TOC.xlsm
    68.2 KB · Views: 5
Hi Narayank991, not sure if I should post here or create a new thread?
I've been asked to do more on this workbook to add columns of information for each line within the TOC. I was thinking a vlookup would give me what I wanted, because it works in a normal vlookup formula on the TOC sheet.

but I would like that vlookup to be placed within the macro that you wrote/amended above.

This is what I tried to use, but it isnt working.

Code: 
Cells(cRow - 1 + cSht, cCol + 2) = Sheets(Sheets(cSht).Name).Application.WorksheetFunction.VLookup("x", Sheets(Sheets(cSht).Name).Rage("A:B"), 2, 0).Value
 
Hi ,

Can you explain in greater detail how information is to be looked up ?

For instance , against the project code DP1234 , what is supposed to appear in the cells C11 , D11 , E11 and F11 ?

Within the code you are looking up the letter x , but in the worksheet you have used exclamation marks ! and !!.

Narayan
 
Yellow cells are the cells that are to have information/dates typed into them.

so for, C11:F11 its just a heading, nothing to be typed into the blue cells.

re the x and XX and ! and !! ... I was playing around with what looks visually better and still able to be used in the code. I altered the code when I altered the symbol ...but forgot to post the workbook at the same time that I posted the code within my question.
 
Hi ,

I am still not clear on what you want ; I am uploading the file you had uploaded ; in this file C11 , D11 , E11 and F11 seem to be the cells which should have something in them corresponding to the project code in A11.

Can you indicate what these cells should have , and from which cells this data should come ?

Narayan
 

Attachments

  • Form - Project Tracking.xlsm
    91.3 KB · Views: 2
The Table of Contents (TOC) tab is to hold a summary of information from all of the tabs in the workbook, except the tabs excluded in the macro; and then hyperlink the Project Code to that tab.

To do this, in each project code's tab, there are formulas to calculate (columns G & H) if a project's milestone has been completed or if the date determined by the calculations is due (!) or overdue (!!); as shown in column I (and column A, purely for vlookup to work).

So, all the yellow cells in the project tabs are to have information typed into them. the yellow cells that require dates then have the calculation on them, as described above. When these dates are due (!) or overdue (!!) the corresponding milestone (column B on the project tab) needs to then appear on the TOC (at column C for due and column E for overdue AND the relevant comment for that milestone) when a refresh is done (with the button on the TOC tab).

So, using A11:F11 on TOC as the example:

A11: DP1234
B11: ='DP1234'!C5
C11:F11: ...um I just realised that the vlookup isnt returning the correct milestone that I wanted :(

C11: was meant to look up DP1234, column I, and find which milstone had the first ! against it and then return the corresponding milstone description in column B.

D11: lookup DP1234, column I, find the same milestone for C11 and return the corresponding comments from column J.

E11: was meant to look up DP1234, column I, and find which milstone had the first !! against it and then return the corresponding milstone description in column B.

F11: lookup DP1234, column I, find the same milestone for E11 and return the corresponding comments from column J.

....I think Im just way in over my head now I detail it all.

thanks so much for your help.
 
You must log in or register to reply here.
Back
Top