I just found this in my library of code; may get you started:
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# 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
--
Ryan---
If this information was helpful, please indicate this by clicking ''Yes''.
stainless said:
On the opening of an excel file with a number of worksheets named as
follows:
FDC
Packs
Covers
I would like the following to occur:
1. A selection list of the current worksheet names (these may
change so I want this to be dynamic) to be displayed in some kind of
message box (radio buttons, listbox,any method would do).
2. On selecting one of these and pressing OK, a Microsoft file
selection window will be displayed ( this is to allow me to pick up a
file of raw data from a folder)
3. When a file is selected and OK is pressed, the sheet selected
will become the selected sheet and I will then perform some sheet
specific code using the raw data to build a report in this worksheet.
I realis this aspect will need to be hardcoded as I will need to
recognise the worksheet selected via VBA code to run the correct code.
I would love any help on this, including any simple example code that
I can tailor.
Thanks
Mark
.
