创建自动分类页面，创建一个TOC /指数，并添加超链接回TOC

Question

我有几个宏在Excel 2010中，我想每个宏继续是这样的：

在点击+或者“创建新的工作表”我想为工作表名称是要创建一个提示... [前往#Sort_Active_Book]

Sort_Active_Book
运行一个名为宏‘Sort_Active_Book’的标签字母数字排序离开TOC作为第一个标签（在左侧）... [前往#Rebuild_TOC]

Rebuild_TOC
使用另一个名为“Rebuild_TOC/Index”的宏重建TOC/Index。重建TOC将删除该页面，然后在开始时创建一个新页面并将其命名为“TOC”

最好将它们分开，以便稍后可以分别使用每个宏来扩展功能/多功能性。有了这个工作簿每天都在使用，我需要能够调用这些宏的一些。

我已经有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只要求如果仅在手动运行时升序/降序（可能需要创建一个不同的宏或将当前代码拆分为另一个宏）。

我被卡住了我应该用它来实现我的目标。

Answer 1

您将需要使用ThisWorkbook代码模块，它可以在这里找到：

双击该代码模块上以显示其模块表。在顶部，使用下拉菜单选择工作簿（左侧下拉菜单），然后使用NewSheet（右侧下拉菜单），如图中所示。

那么你应该能够使用此代码做你在找什么：

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