Hi
does anybody know how to copy&paste a list of worksheets (contents) that could be seeing in Properties?
Sometimes i need this to prepare an explanatory letter or notes to my workbook, etc.
Thanks for your help anyway
Valerii
Hi
does anybody know how to copy&paste a list of worksheets (contents) that could be seeing in Properties?
Sometimes i need this to prepare an explanatory letter or notes to my workbook, etc.
Thanks for your help anyway
Valerii
Here's a tip from Gary Brown.... (paste this in a new module in your workbook-let me know if you help with that step)
"...here's a module that will create a Table of Contents worksheet
with a hyperlink to each worksheet...."
=====================
Sub WorksheetNamesWithHyperLink()
'Create a separate worksheet with the name of each sheet
' in the workbook as a hyperlink to that sheet -
' i.e. a Table Of Contents
'07/25/2000 - allow for chart sheets
'05/07/2002 - add manual calculation
Dim aryHiddensheets()
Dim iRow As Integer, iColumn As Integer, y As Integer
Dim i As Integer, x As Integer, iSheets As Integer
Dim objOutputArea As Object
Dim strTableName As String, strSheetName As String
Dim strOrigCalcStatus As String
strTableName = "Table_of_Contents"
'save calculation setting
Select Case Application.Calculation
Case xlCalculationAutomatic
strOrigCalcStatus = "Automatic"
Case xlCalculationManual
strOrigCalcStatus = "Manual"
Case xlCalculationSemiautomatic
strOrigCalcStatus = "SemiAutomatic"
Case Else
strOrigCalcStatus = "Automatic"
End Select
'set workbook to manual
Application.Calculation = xlCalculationManual
'Count number of sheets in workbook
iSheets = ActiveWorkbook.Sheets.Count
'redim array
ReDim aryHiddensheets(1 To iSheets)
'put hidden sheets in an array, then unhide the sheets
For x = 1 To iSheets
If Sheets(x).Visible = False Then
aryHiddensheets(x) = Sheets(x).Name
Sheets(x).Visible = True
End If
Next
'Check for duplicate Sheet name
i = ActiveWorkbook.Sheets.Count
For x = 1 To i
If Windows.Count = 0 Then Exit Sub
If UCase(Sheets(x).Name) = UCase(strTableName) Then
Sheets(x).Activate
If Err.Number = 9 Then
Exit For
End If
'turn warning messages off
Application.DisplayAlerts = False
ActiveWindow.SelectedSheets.Delete
'turn warning messages on
Application.DisplayAlerts = True
Exit For
End If
Next
'Add new sheet at end of workbook
' where results will be located
Sheets.Add.Move Before:=Sheets(1)
'Worksheets.Add.Move after:=Sheets(Sheets.Count)
'Name the new worksheet and set up Titles
ActiveWorkbook.ActiveSheet.Name = strTableName
ActiveWorkbook.ActiveSheet.Range("A1").Value = _
"Worksheet (hyperlink)"
ActiveWorkbook.ActiveSheet.Range("B1").Value = _
"Visible / Hidden"
ActiveWorkbook.ActiveSheet.Range("C1").Value = _
" Notes: "
're-hide previously hidden sheets
On Error Resume Next
y = UBound(aryHiddensheets)
For x = 1 To y
Sheets(aryHiddensheets(x)).Visible = False
Next
'Count number of sheets in workbook
iSheets = ActiveWorkbook.Sheets.Count
'Initialize row and column counts for putting
'info into StrTableName sheet
iRow = 1
iColumn = 0
Set objOutputArea = _
ActiveWorkbook.Sheets(strTableName).Range("A1")
'Check Sheet names
For x = 1 To iSheets
Sheets(x).Activate
strSheetName = ActiveSheet.Name
'put information into StrTableName worksheet
With objOutputArea
If strSheetName <> strTableName Then
.Offset(iRow, iColumn) = " " & strSheetName
If UCase(TypeName(ActiveSheet)) <> "CHART" Then
ActiveSheet.Hyperlinks.Add _
Anchor:=objOutputArea.Offset(iRow, _
iColumn), _
Address:="", SubAddress:=Chr(39) & _
strSheetName & Chr(39) & "!A1"
End If
If ActiveSheet.Visible = True Then
.Offset(iRow, iColumn + 1) = " Visible"
.Offset(iRow, iColumn).Font.Bold = True
.Offset(iRow, iColumn + 1).Font.Bold = True
Else
.Offset(iRow, iColumn + 1) = " Hidden"
End If
iRow = iRow + 1
End If
End With
Next x
Sheets(strTableName).Activate
'format worksheet
Range("A:C").Select
With Selection
.HorizontalAlignment = xlLeft
.VerticalAlignment = xlBottom
.WrapText = False
.Orientation = 0
.IndentLevel = 0
.ShrinkToFit = False
.MergeCells = False
End With
With Selection.Font
.Name = "Tahoma"
'.FontStyle = "Regular"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
'.ColorIndex = xlAutomatic
End With
Range("A2").Select
ActiveWindow.FreezePanes = True
Range("A1").Font.Bold = True
Columns("A:C").EntireColumn.AutoFit
Range("A1:C1").Select
With Selection
.HorizontalAlignment = xlCenter
.Font.Underline = xlUnderlineStyleSingle
End With
Range("B1").Select
With ActiveCell.Characters(Start:=1, Length:=7).Font
.FontStyle = "Bold"
End With
With ActiveCell.Characters(Start:=8, Length:=9).Font
.FontStyle = "Regular"
End With
Columns("A:C").EntireColumn.AutoFit
Range("A1:C1").Font.Underline = _
xlUnderlineStyleSingleAccounting
Range("B:B").HorizontalAlignment = xlCenter
Range("C1").HorizontalAlignment = xlLeft
Columns("C:C").ColumnWidth = 65
Range("A1").Select
Select Case strOrigCalcStatus
Case "Automatic"
Application.Calculation = xlCalculationAutomatic
Case "Manual"
Application.Calculation = xlCalculationManual
Case "SemiAutomatic"
Application.Calculation = _
xlCalculationSemiautomatic
Case Else
Application.Calculation = xlCalculationAutomatic
End Select
Application.Dialogs(xlDialogWorkbookName).Show
End Sub
'=====================================================
HTH
Bruce
Bruce
The older I get, the better I used to be.
USA
Bruce, I love this table of contents!
Will come in very handy for a crowded file at work.
Merci and merry christmas.
Best Regards,
Peter
There are currently 1 users browsing this thread. (0 members and 1 guests)
Bookmarks