Добавление гиперссылки на ячейку, когда ячейка и местоположение являются динамическими - PullRequest
Новая
       14

Добавление гиперссылки на ячейку, когда ячейка и местоположение являются динамическими

1 голос
/ 01 февраля 2020

У меня есть подпрограмма, которая при вводе имени в ячейку создает новый лист с тем же именем и добавляет его в список. 

Sub AddNewTitle()

Dim DshB As Worksheet, WS As Worksheet
Set DshB = ThisWorkbook.Worksheets("Dashboard")
Set WS = Sheets.Add(after:=Sheets("Data"))

WS.Name = DshB.Range("C2").Value

Dim NewTitle As Range, Header As Range, AyOne As Range
Set NewTitle = DshB.Range("C2")
Set AyOne = WS.Range("A1")
Set Header = WS.Range("A1:L1")

With NewTitle
    DshB.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0) = .Value 'Name added to list
End With

AyOne = NewTitle
Header.Merge
Header.Font.Size = 15
Header.Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlDouble

NewTitle.ClearContents

End Sub

Я хотел бы, чтобы имя было добавлен в список, свяжите его с новым листом.

Как мне сделать гиперссылку на имя листа, которое будет отличаться каждый раз?

1 Ответ

1 голос
/ 01 февраля 2020 
Add the link like this

DshB.Hyperlinks.Add _
    Anchor:=cell, _
    Address:="", _
    SubAddress:="'" & NewTitle & "'!A1", _
    TextToDisplay:=NewTitle

Вот полный скрипт с некоторыми добавленными проверками для существующих листов 

Sub AddNewTitle()

    Const TITLE As String = "C2"

    Dim DshB As Worksheet, ws As Worksheet
    Set DshB = ThisWorkbook.Worksheets("Dashboard")

    Dim NewTitle As String
    NewTitle = DshB.Range(TITLE).Value

    'check Not blank
    If Len(NewTitle) = 0 Then
        MsgBox "Empty cell C2", vbCritical
        Exit Sub
    End If

    ' check not existing
    For Each ws In ThisWorkbook.Sheets
        If ws.NAME = NewTitle Then
           MsgBox NewTitle & " is an existing sheet ", vbCritical
           Exit Sub
        End If
    Next

    Set ws = Sheets.Add(after:=Sheets("Data"))
    ws.NAME = NewTitle
    ws.Range("A1").Value = NewTitle
    With ws.Range("A1:L1")
        .Merge
        .Font.Size = 15
        .Borders(xlEdgeBottom).LineStyle = XlLineStyle.xlDouble
    End With

    Dim cell As Range
    Set cell = DshB.Cells(Rows.Count, "B").End(xlUp).Offset(1, 0)

    DshB.Hyperlinks.Add _
    Anchor:=cell, _
        Address:="", _
        SubAddress:="'" & NewTitle & "'!A1", _
        TextToDisplay:=NewTitle

    DshB.Range(TITLE).ClearContents
    DshB.Activate

End Sub
...