VBA从列表创build超链接
我有下面的VBA：
Sub List_creator() ' ' List_creator Macro ' Creates list of Names which will then become tab names ' ' Sheets("ALL Scheme Derivatives").Select ActiveSheet.Range("$A$1:$Q$64944").AutoFilter Field:=9, Criteria1:=Array( _ "A - Mini", "B - Supermini", "C - Lower Medium", "D - Upper Medium", _ "E - Executive", "G - Specialist Sports", "H - MPV", "I - 4 x 4", "Y - LCV", "="), _ Operator:=xlFilterValues Columns("B:B").Select Selection.SpecialCells(xlCellTypeVisible).Select Selection.Copy Sheets("List").Select Sheets("List").Name = "List" Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Range("$A$1:$A$1047980").RemoveDuplicates Columns:=1, Header:= _ xlNo Dim ws As Worksheet Dim Ki As Range Dim ListSh As Range With Worksheets("List") Set ListSh = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With On Error Resume Next For Each Ki In ListSh If Len(Trim(Ki.Value)) > 0 Then If Len(Worksheets(Ki.Value).Name) = 0 Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value ActiveSheet.[a1] = ActiveSheet.Name 'Copy from sheet Helper Sheets("Helper").Range("A2:K92").Copy Destination:=ActiveSheet.Range("A2") ' Sets column widths Columns("B:C").ColumnWidth = 10.71 Columns("D").ColumnWidth = 70.71 Columns("E:J").ColumnWidth = 10.71 ' Deletes all rows which aren't needed Dim LR As Long, Found As Range LR = Range("C" & Rows.Count).End(xlUp).Row Set Found = Columns("C").Find(what:="-", LookIn:=xlValues, lookat:=xlWhole) If Not Found Is Nothing Then Rows(Found.Row & ":" & LR).Delete End If End If Next Ki ' Return to Manual Sheets("MANUAL").Select End Sub 这将创build一个名称列表（删除任何重复项），然后为列表中的每个名称，一个新的工作表被添加到工作簿。 这些新的工作表具有上述创build列表中显示的确切名称。 有没有办法，我可以创build一个名为“内容”（单元格L8，每行有一个超链接）的单独的工作表上创build这些工作表的每个超链接。
谢谢！
编辑：
Sub List_creator() ' ' List_creator Macro ' Creates list of Names which will then become tab names ' ' Sheets("ALL Scheme Derivatives").Select ActiveSheet.Range("$A$1:$Q$64944").AutoFilter Field:=9, Criteria1:=Array( _ "A - Mini", "B - Supermini", "C - Lower Medium", "D - Upper Medium", _ "E - Executive", "G - Specialist Sports", "H - MPV", "I - 4 x 4", "Y - LCV", "="), _ Operator:=xlFilterValues Columns("B:B").Select Selection.SpecialCells(xlCellTypeVisible).Select Selection.Copy Sheets("List").Select Sheets("List").Name = "List" Range("A1").Select Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Application.CutCopyMode = False ActiveSheet.Range("$A$1:$A$1047980").RemoveDuplicates Columns:=1, Header:= _ xlNo Dim ws As Worksheet Dim Ki As Range Dim ListSh As Range Dim iLinkRow As Integer With Worksheets("List") Set ListSh = .Range("A2:A" & .Cells(.Rows.Count, "A").End(xlUp).Row) End With On Error Resume Next For Each Ki In ListSh If Len(Trim(Ki.Value)) > 0 Then If Len(Worksheets(Ki.Value).Name) = 0 Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value ActiveSheet.[a1] = ActiveSheet.Name iLinkRow = 11 Sheets("Contents").Hyperlinks.Add Anchor:=Sheets("Contents").Cells(iLinkRow, 8), Address:=ActiveSheet.Name, SubAddress:=ActiveSheet.Name, TextToDisplay:=ActiveSheet.Name iLinkRow = iLinkRow + 1 'Copy from sheet Helper Sheets("Helper").Range("A2:K92").Copy Destination:=ActiveSheet.Range("A2") ' Sets column widths Columns("B:C").ColumnWidth = 10.71 Columns("D").ColumnWidth = 70.71 Columns("E:J").ColumnWidth = 10.71 ' Deletes all rows which aren't needed Dim LR As Long, Found As Range LR = Range("C" & Rows.Count).End(xlUp).Row Set Found = Columns("C").Find(what:="-", LookIn:=xlValues, lookat:=xlWhole) If Not Found Is Nothing Then Rows(Found.Row & ":" & LR).Delete End If End If Next Ki ' Return to Manual Sheets("MANUAL").Select End Sub
您可以在工作簿中添加引用其他工作表的超链接，如下所示：
ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _ "Sheet2!A1", TextToDisplay:="Sheet2!A1"
因此，例如，如果您有一张名为John的工作表，则可以使用以下内容将链接添加到Contents表单元格L8 …
Sheets("Contents").Hyperlinks.Add Anchor:=Sheets("Contents").Range("L8"), Address:="", SubAddress:= _ "John!A1", TextToDisplay:="John"
您应该能够在创build工作表的循环中放置一行类似于此的代码（显然，不需要对SubAddress和TextToDisplay参数进行硬编码）。
您还需要更新Anchor参数。 我们假设以下循环
Dim iLinkRow as Integer iLinkRow = 11 For Each Ki in ListSh 'your code that creates the sheet Sheets("Contents").Hyperlinks.Add Anchor:=Sheets("Contents").Cells(iLinkRow, 8), Address:="", SubAddress:= _ ActiveSheet.Name, TextToDisplay:=ActiveSheet.Name iLinkRow = iLinkRow + 1 Next Ki
在这里，我使用Cells(y,x) （而不是Range ），它接受两个整数行，列 。 列号将始终为8（ L为第8列），行（ iLinkRow ）将为每张表增加1。
更新代码如下…
On Error Resume Next iLinkRow = 11 For Each Ki In ListSh If Len(Trim(Ki.Value)) > 0 Then If Len(Worksheets(Ki.Value).Name) = 0 Then Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = Ki.Value ActiveSheet.[a1] = ActiveSheet.Name Sheets("Contents").Hyperlinks.Add Anchor:=Sheets("Contents").Cells(iLinkRow, 8), Address:=ActiveSheet.Name, SubAddress:=ActiveSheet.Name, TextToDisplay:=ActiveSheet.Name iLinkRow = iLinkRow + 1
在循环开始之前，您需要设置iLinkRow = 11 ！