Excel - 希望使用 VBA 构建一个复制了额外单元格的目录

Question

我有一个很好的基本脚本，它返回工作簿中每个工作表的工作表名称，但现在我想将单元格 A1、A2、A3 和 A4 的内容添加到 B、C、D 和 E 列中，在 A、B、C、D 列中添加带有“链接、变量、定义、计算、注释”的标题行。现有的超链接将在 A 列中。

它将需要遍历整个工作簿，如果可能，跳过向目录页面添加链接。 这是我目前使用的基本脚本（从 Extend Office 借来）-

'updateby Extendoffice 20180413
    Dim xAlerts As Boolean
    Dim I  As Long
    Dim xShtIndex As Worksheet
    Dim xSht As Variant
    xAlerts = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Table of contents").Delete
    On Error GoTo 0
    Set xShtIndex = Sheets.Add(Sheets(1))
    xShtIndex.Name = "Table of contents"
    I = 1
    Cells(1, 1).Value = "Table of contents"
    For Each xSht In ThisWorkbook.Sheets
        If xSht.Name <> "Table of contents" Then
            I = I + 1
            xShtIndex.Hyperlinks.Add Cells(I, 1), "", "'" & xSht.Name & "'!A1", , xSht.Name
        End If
    Next
    Application.DisplayAlerts = xAlerts
End Sub

Answer 1

不确定这是否完全符合您的要求，关于您希望如何处理链接功能的解释存在一些空白。 既然您提到代码“有效”，但您想要一些附加功能，并且您不想要“目录”上的链接，但它现在也不这样做？

无论如何，试一试......

Private Sub CommandButton1_Click()
    
    Dim xAlerts As Boolean
    Dim I  As Long
    Dim xShtIndex As Worksheet
    Dim Table As Worksheet
    Dim xSht As Variant
    xAlerts = Application.DisplayAlerts
    Application.DisplayAlerts = False
    On Error Resume Next
    Sheets("Table of contents").Delete
    On Error GoTo 0
    Set xShtIndex = Sheets.Add(Sheets(1))
    xShtIndex.Name = "Table of contents"
    Set Table = Worksheets("Table of contents")
    I = 2
    targetcolumn = 1
    'Cells(1, 1).Value = "Table of contents"
    'Disabled this because i'm not sure if this code should be here?
    For Each xSht In ThisWorkbook.Sheets
        With xSht
            If xSht.Name = "Table of contents" Then
                .Cells(1, 1).Value = "Table of contents"
                .Range("A1").Value = "Link"
                .Range("B1").Value = "Variable"
                .Range("C1").Value = "Definition"
                .Range("D1").Value = "Calculation"
                .Range("E1").Value = "Notes"
            End If
            
            If xSht.Name <> "Table of contents" Then
                    lrow = .Cells(.Rows.Count, "A").End(xlUp).Row
                    Dim copyrng As Range
                    Set copyrng = .Range("A1:A" & lrow)
                    copycount = 2 'skipping one because with 1 it would write to row 1 which is where the headers are
                    For Each cell In copyrng
                        Table.Cells(targetcolumn, copycount).Value = cell.Value
                    copycount = copycount + 1
                    Next
                Table.Hyperlinks.Add Table.Cells(I, 1), "", "'" & xSht.Name & "'!A1", , xSht.Name
                I = I + 1

            End If

        End With
        targetcolumn = targetcolumn + 1
    Next
    Application.DisplayAlerts = xAlerts
End Sub