创建自动排序页面，创建 TOC/Index，并将超链接添加回目录

Question

我在 Excel 2010 年有几个宏，我希望每个宏都执行如下操作：

单击 + 或 "Create New Worksheet" 后，我希望提示输入要创建的 sheet 名称...[继续#Sort_Active_Book]

Sort_Active_Book
运行一个名为 "Sort_Active_Book" 的宏，用于按字母数字顺序对选项卡进行排序，将 TOC 作为第一个选项卡（在左侧）... [继续 #Rebuild_TOC]

Rebuild_TOC
使用另一个名为 "Rebuild_TOC/Index. Rebuilding the TOC will delete the page and then create a new page at the beginning and name it "TOC"

的宏重建 TOC/Index

最好将它们分开，这样我以后可以在 expand-ability/versatility 中单独使用每个宏。由于每天都使用此工作簿，我需要能够调用其中一些宏。

我已有的 Rebuild_TOC 代码是：

Sub Rebuild_TOC()
Dim wbBook As Workbook
Dim wsActive As Worksheet
Dim wsSheet As Worksheet
Dim lnRow As Long
Dim lnPages As Long
Dim lnCount As Long
Set wbBook = ActiveWorkbook

With Application
    .DisplayAlerts = False
    .ScreenUpdating = False
    .EnableEvents = False
End With
'' Calls sub to organize the tabs in alphabetical order while keeping "TOC" as the FIRST tab.'
Application.Run("Sort_Active_Book")
'' Removed calling the Create_Back_Links line because I think It's possible to integrate into the existing code with it
'' already iterating through the worksheets.
' Application.Run("Create_Back_Links")

'' If the TOC sheet already exists, delete it and add a new
'' worksheet as the first in the document.
On Error Resume Next
With wbBook
    .Worksheets("TOC").Delete
    .Worksheets.Add Before:=.Worksheets(1)
End With
On Error GoTo 0
Set wsActive = wbBook.ActiveSheet
With wsActive
    .Name = "TOC"
    With .Range("A1:B1")
        .Value = VBA.Array("Table of Contents", "Sheet #")
        .Font.Bold = True
    End With
End With
lnRow = 2
lnCount = 1
'' Iterate through the worksheets in the workbook and create
'' sheetnames, add hyperlink and count & write the running number
'' of pages to be printed for each sheet on the TOC sheet.
For Each wsSheet In wbBook.Worksheets
    If wsSheet.Name <> wsActive.Name Then
        wsSheet.Activate
        With wsActive
            .Hyperlinks.Add .Cells(lnRow, 1), "", SubAddress:="'" & wsSheet.Name & "'!A1", TextToDisplay:=wsSheet.Name
            .Cells(lnRow, 2).Value = "'" & lnCount
        End With
        .Range("A1").Select
        .Range("A1").ClearContents
         '' Instead of placing text in cell A1 I've decided to use the hyperlink's TextToDisplay instead.
         ' .Range("A1").Value = "Back to TOC"
        .ActiveCell.Hyperlinks.Add Anchor:=("A1"), Address:="", SubAddress:="", TextToDisplay: = "Back to TOC"
        lnRow = lnRow + 1
        lnCount = lnCount + 1
    End If
Next wsSheet
wsActive.Activate
wsActive.Columns("A:B").EntireColumn.AutoFit
With Application
    .DisplayAlerts = True
    .ScreenUpdating = True
    .EnableEvents = True
End With
End Sub

我已有的 Sort_Active_Book 代码是（我已经知道有效）：

Sub Sort_Active_Book()
Dim TotalSheets As Integer
Dim p As Integer
Dim iAnswer As VbMsgBoxResult

'
' Move the TOC to the begining of the document.
'
  Sheets("TOC").Move Before:=Sheets(1)
'
' Prompt the user as to which direction they wish to
' sort the worksheets.
'
   iAnswer = MsgBox("Sort Sheets in Ascending Order?" & Chr(10) & "Clicking No will sort in Descending Order", vbYesNoCancel + vbQuestion + vbDefaultButton1, "Sort Worksheets")
   For TotalSheets = 1 To Sheets.Count
      For p = 2 To Sheets.Count - 1
'
' If the answer is Yes, then sort in ascending order.
'
         If iAnswer = vbYes Then
            If UCase$(Sheets(p).Name) = "TOC" Then
               Sheets(p).Move Before:=Sheets(1)
            ElseIf UCase$(Sheets(p).Name) > UCase$(Sheets(p + 1).Name) Then
               Sheets(p).Move After:=Sheets(p + 1)
            End If
'
' If the answer is No, then sort in descending order.
'
         ElseIf iAnswer = vbNo Then
            If UCase$(Sheets(p).Name) = "TOC" Then
                Sheets(p).Move Before:=Sheets(1)
            ElseIf UCase$(Sheets(p).Name) < UCase$(Sheets(p + 1).Name) Then
               Sheets(p).Move After:=Sheets(p + 1)
            End If
         End If
      Next p
   Next TotalSheets
End Sub

我希望 Sort_Active_Book 仅在运行手动时才询问是否 ascending/descending （可能需要创建不同的宏或将当前代码拆分为另一个宏（ s).

我不知道应该朝哪个方向去实现我的目标。

Answer 1

您将需要使用 ThisWorkbook 代码模块，可在此处找到：

双击该代码模块以调出其模块 sheet。如图所示，在顶部，使用下拉菜单 select Workbook（left-hand 下拉菜单）和 NewSheet（right-hand 下拉菜单）。

那么您应该能够使用此代码来执行您要查找的操作：

Private Sub Workbook_NewSheet(ByVal Sh As Object)

    Dim sName As String
    Dim bValidName As Boolean
    Dim i As Long

    bValidName = False

    Do While bValidName = False
        sName = InputBox("Please name this new worksheet:", "New Sheet Name", Sh.Name)
            If Len(sName) > 0 Then
            For i = 1 To 7
                sName = Replace(sName, Mid(":\/?*[]", i, 1), " ")
            Next i
            sName = Trim(Left(WorksheetFunction.Trim(sName), 31))
            If Not Evaluate("ISREF('" & sName & "'!A1)") Then bValidName = True
        End If
    Loop

    Sh.Name = sName

    Call Sort_Active_Book
    Call Rebuild_TOC

End Sub

创建自动排序页面，创建 TOC/Index，并将超链接添加回目录

Create auto sort pages, create a TOC/Index, and add hyperlinks back to the TOC

excel

vba

tableofcontents

excel-2010