在工作表中列出工作表名称，对其进行超链接，并在添加/删除工作表时更新列表 [英] List sheet names in a sheet, hyperlink them, and update list whenever sheets are added/deleted

问题描述

我发现了几个代码，这些代码列出了工作表中的所有工作表名称并对其进行超链接.我想列出工作表"ListSheet"中的所有工作表，并使其成为超链接.

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.

以下代码有两个问题:

1)如果我添加或删除工作表(sub add_list()或sub delete_list()子程序)，它应该删除上一个列表并插入新的列表，但是当我删除工作表时，列表保留旧的工作表名称(因此该列表可能在创建新列表之前不会被删除.)

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)列表始终在同一单元格和向下的单元格中创建，但并不总是在工作表"ListSheet"中创建.是因为活动"工作表在"sub add_list()"和"sub delete_list()"中更改了吗?

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

还有

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

还有

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!

推荐答案

(VBA)编程的一些主要原理没有并入您的原始代码，这很可能会导致其失败:

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

1. 避免 Select 和 ActiveSheet (除非绝对需要).
2. 用显式类型和名称声明所有变量(使用Option Explicit来确保正确使用变量).
3. 将过程分解为较小的组件(这不是代码的大问题，只是奖励:))

此重构代码应该可以更好地工作:

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

这篇关于在工作表中列出工作表名称，对其进行超链接，并在添加/删除工作表时更新列表的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！