使用 excel 创建包含名称和指向该名称的超链接的动态范围

Question

我正在尝试开发一个快速简便的项目管理跟踪器。我目前正在使用输入框来获取要添加的项目名称（PrjName）。然后代码将复制模板并将其粘贴到下一个可用列的“项目”工作表中（+1 表示项目之间的额外空间）。然后，我想将 PrjName 添加为仪表板工作表上的项目列表，但将其添加为超链接，该超链接将链接到项目已粘贴到“项目”工作表上的相应列。我已经想出了如何复制/粘贴我希望它看起来的方式，但我什至不知道如何开始为超链接创建参考。我想我可以通过使用项目名称来创建一个命名范围，该范围以某种方式引用粘贴的信息，然后为超链接引用该名称，但不知道如何实现这一点。到目前为止，这是我所拥有的，但距离正确可能还有很长的路要走。

Private Sub CommandButton1_Click()
Dim FirstBlankCol As Range

PrjName = InputBox("Enter the name of the project", "User Input Required")
If PrjName = "" Then Exit Sub

'Find First Blank Cell to add new Project on Summary Worksheet
Set FirstBlankCol = Range("B" & Rows.Count).End(xlUp).Offset(1, 0)
Worksheets("Summary").Hyperlinks.Add Anchor:=FirstBlankCol, Address:="", SubAddress:= _
"PrjName", TextToDisplay:=PrjName

With Sheets("Projects")
    Select Case Sheets("Projects").Range("A1") = ""
        Case True 'paste in Col A if A1 is empty
            Sheets("Template").Range("A1:F5").Copy
            Sheets("Projects").Range("A1") _
            .PasteSpecial Paste:=xlPasteColumnWidths
            Sheets("Projects").Range("A1") _
            .PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        Case False 'paste in next col
            Sheets("Template").Range("A1:F5").Copy
            Sheets("Projects").Range("IV1").End(xlToLeft).Offset(0, 6) _
            .PasteSpecial Paste:=xlPasteColumnWidths
            Sheets("Projects").Range("IV1").End(xlToLeft).Offset(0, 6) _
            .PasteSpecial Paste:=xlPasteAllUsingSourceTheme
        End Select
        Application.CutCopyMode = False
End With

End Sub

Answer 1

试试这个：

Private Sub CommandButton1_Click()

    Dim ws As Worksheet
    Dim wsPrj As Worksheet
    Dim wsTmp As Worksheet
    Dim rngDest As Range
    Dim strProjectName As String

    strProjectName = InputBox("Enter the name of the project", "User Input Required")
    If Len(Trim(strProjectName)) = 0 Then Exit Sub  'Pressed cancel

    Set ws = ActiveSheet
    Set wsPrj = Sheets("Projects")
    Set wsTmp = Sheets("Template")

    Application.ScreenUpdating = False
    If Len(wsPrj.Range("A1").Text) = 0 Then Set rngDest = wsPrj.Range("A1") Else Set rngDest = wsPrj.Cells(1, Columns.Count).End(xlToLeft).Offset(, 6)
    wsTmp.Range("A1:F5").Copy
    rngDest.PasteSpecial xlPasteAllUsingSourceTheme
    rngDest.PasteSpecial xlPasteColumnWidths
    Application.CutCopyMode = False

    ActiveWorkbook.Names.Add Replace(strProjectName, " ", "_"), "='" & wsPrj.Name & "'!" & rngDest.Address
    ws.Hyperlinks.Add ws.Cells(Rows.Count, "B").End(xlUp).Offset(1), "", Replace(strProjectName, " ", "_"), , strProjectName
    Application.ScreenUpdating = True

End Sub