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$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

这将创建一个名称列表（删除任何重复项），然后对于列表中的每个名称，将新工作表添加到工作簿中。这些新工作表具有与上述创建列表中显示的完全相同的名称。有没有办法我可以在一个名为＆＃34;内容＆＃34;的单独工作表上创建一个指向这些创建的工作表中的每一个的超链接。（从单元格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$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

Answer 1

您可以在工作簿中添加引用其他工作表的超链接，如下所示......

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

例如，如果您有一张名为John的工作表，则可以使用以下内容在L8工作表上的单元格Contents中添加链接...

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

您应该能够在创建工作表的循环中放置一行与此类似的代码（显然没有对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！

VBA从列表中创建超链接

1 个答案: