VBA 从列表创建超链接

Question

我有以下 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:$Q944").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:$A47980").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

这将创建一个名称列表（删除所有重复项），然后对于列表中的每个名称，都会将一个新工作表添加到工作簿中。这些新工作表的名称与上述创建的列表中显示的名称完全相同。有没有一种方法可以让我在名为 "Contents" 的单独工作表上创建指向这些创建的每个工作表的超链接（从单元格 L8 开始，每行有一个超链接）。

谢谢！

编辑：

Sub List_creator()
'
' List_creator Macro
' Creates list of Names which will then become tab names
'

'
Sheets("ALL Scheme Derivatives").Select
ActiveSheet.Range("$A:$Q944").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:$A47980").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

Answer 1

您可以在您的工作簿中添加引用其他 sheet 的 hyperlink，如下所示...

ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="", SubAddress:= _
    "Sheet2!A1", TextToDisplay:="Sheet2!A1"

因此，例如，如果您有一个名为 John 的 sheet，您将使用以下命令将 link 添加到 [=16= 上的单元格 L8 中] sheet...

Sheets("Contents").Hyperlinks.Add Anchor:=Sheets("Contents").Range("L8"), Address:="", SubAddress:= _
    "John!A1", TextToDisplay:="John"

您应该能够在创建工作sheets 的循环中放入一行与此类似的代码（显然无需对 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 列），每 sheet.

行（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！

VBA 从列表创建超链接

VBA to create hyperlinks from a list

excel

vba

hyperlink