List sheet names in a sheet, hyperlink them, and update list whenever sheets are added/deleted

问题

I have found several codes that lists all the sheet names in a sheet and hyperlink them. I want to list all the sheets in the sheet "ListSheet" and make them hyperlinks.

Two issues with the following code:

1) It should delete the previous list and insert the new one, in case I add or delete sheets (sub add_list() or sub delete_list()), but when I delete sheets the list keeps the old sheet names (so the list is probably not deleted before the new is created).

2) The list always created in the same cell and down, but not always created in the sheet "ListSheet". Is that because the "active" sheet is changed in the "sub add_list()" and "sub delete_list()"?

Sub add_list()
Sheets(4).Copy Before:=Sheets("8")
Call TOC
End Sub

And

Sub delete_sheet()
ActiveSheet.Select
ActiveWindow.SelectedSheets.Delete
Call TOC
End Sub

And

Sub TOC()
Dim objSheet As Object
Dim intRow   As Integer
Dim strCol   As Integer
Dim GCell As Range

SearchText = "Word"
Set GCell = Worksheets("ListSheet").Cells.Find(SearchText).Offset(2, -1)

GCell.End(xlDown).ClearContents

Set objSheet = Excel.Sheets
intRow = GCell.Row
strCol = GCell.Column

For Each objSheet In ActiveWorkbook.Sheets
    With Worksheet
    Cells(intRow, strCol).Select
    Worksheets("ListSheet").Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
    "'" & objSheet.Name & "'!A1", TextToDisplay:=objSheet.Name
        With Selection.Font
            .Name = "Calibri"
            .FontStyle = "Normal"
            .Size = 11
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .ThemeColor = xlThemeColorLight1
            .TintAndShade = 0
            .ThemeFont = xlThemeFontMinor
        End With
    intRow = intRow + 1
    End With
Next

Any input, hints or lectures are welcome. Thanks in advance!

回答1:

There are few main principles of (VBA) programming not incorporated your original code that are probably causing it fail:

Avoid Select and ActiveSheet (except when absolutely needed).
Declare all variables with explicit types and names (using Option Explicit to ensure variables are used properly).
Break procedures into smaller components (not a huge issue with your code, just as a bonus :))

This refactored code should work a lot better:

Option Explicit

Sub addList()

    Sheets(4).Copy Before:=Sheets("8")
    writeTOC

End Sub

Sub deleteSheet()

    Application.DisplayAlerts = False
    ActiveSheet.Delete
    Application.DisplayAlerts = True

    writeTOC

End Sub

Sub writeTOC()

    Dim listSheet As Worksheet
    Set listSheet = ThisWorkbook.Worksheets("ListSheet")

    Dim searchText As String
    searchText = "Word"

    Dim gCell As Range
    Set gCell = listSheet.Cells.Find(searchText).Offset(2, -1)
    gCell.End(xlDown).ClearContents

    Dim i As Integer
    Dim sht As Worksheet

    For Each sht In ThisWorkbook.Worksheets

        listSheet.Hyperlinks.Add Anchor:=gCell.Offset(i), Address:="", SubAddress:="'" & sht.Name & "!A1", TextToDisplay:=sht.Name
        formatLinkCell gCell.Offset(i)

        i = i + 1

    Next

End Sub

Sub formatLinkCell(rng As Range)

    With rng.font
        .Name = "Calibri"
        .FontStyle = "Normal"
        .Size = 11
        .Strikethrough = False
        .Superscript = False
        .Subscript = False
        .OutlineFont = False
        .Shadow = False
        .Underline = xlUnderlineStyleNone
        .ThemeColor = xlThemeColorLight1
        .TintAndShade = 0
        .ThemeFont = xlThemeFontMinor
    End With

End Sub

来源：https://stackoverflow.com/questions/48158966/list-sheet-names-in-a-sheet-hyperlink-them-and-update-list-whenever-sheets-are

标签

vba

excel-vba

excel