excel - 试图从 "Main"表自动添加超链接到新的自动化表？

Question

希望大家都好。
我正在尝试为我们的小型企业开发项目日志。
我找到了一种快速巧妙的方法，只需使用小弹出框来输入最小的必要信息请求。 (项目名称)复制隐藏工作表(此处称为“offert”)并将其复制到具有新输入名称的新工作表。

我试图做什么(并尝试过各种形式的 Hyperlink.add 等)希望新的用户输入名称作为超链接添加到代码中称为“offertliggare”的“主”工作表上，只要新工作表已创建。然后，这些新链接应该从主表格中的单元格 A3 向下填充。

我尝试过各种形式，并尝试更深入地研究 vba 并搜索其他线程但找不到解决方案。
任何帮助将不胜感激，谢谢。

Sub DupSheet()

    Dim Actsheet As String
    Application.ScreenUpdating = False
    On Error Resume Next
    ActiveWorkbook.Sheets("Offert").Visible = True
    ActiveWorkbook.Sheets("Offert").Copy _
    after:=ActiveWorkbook.Sheets("Offert")
    ActNm = ActiveSheet.Name
    ActiveSheet.Name = InputBox("Enter the name for the new sheet.")
    Sheets(ActiveSheet.Name).Visible = True
    ActiveWorkbook.Sheets("Offert").Visible = False
    Application.ScreenUpdating = True

End Sub

Answer 1

复制工作表并添加超链接

Option Explicit

Sub DupSheet()

    Const sName As String = "Offert"
    Const lName As String = "Offertliggare"
    Const lfCellAddress As String = "A3"
    Const dCellAddress As String = "A1"
    Const DeleteIfNoName As Boolean = False

    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code

    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    sws.Visible = xlSheetVisible
        sws.Copy After:=sws
        ' Or (as the last sheet):
        'sws.Copy After:=wb.Sheets(wb.Sheets.Count)
        Dim dws As Worksheet: Set dws = wb.ActiveSheet
    sws.Visible = xlSheetHidden
    
    Dim dName As String
    Dim ErrNum As Long

    Do
        dName = InputBox(Prompt:="Enter the new name.", _
            Title:="Copy 'Offert'")
        ' No entry or cancel.
        If Len(dName) = 0 Then
            If DeleteIfNoName Then ' delete the worksheet and exit
                Application.DisplayAlerts = False ' delete without confirmation
                dws.Delete
                Application.DisplayAlerts = True
                Exit Sub
            Else ' use the generic name
                dName = dws.Name
                Exit Do
            End If
        End If
        ' Attempt to rename.
        On Error Resume Next
            dws.Name = dName
            ErrNum = Err.Number
        On Error GoTo 0
        If ErrNum = 0 Then ' valid name
            Exit Do
        End If
    Loop
    
    Dim lws As Worksheet: Set lws = wb.Worksheets(lName)
    Dim lfCell As Range: Set lfCell = lws.Range(lfCellAddress)
    
    Dim ldCell As Range
    With lfCell.Resize(lws.Rows.Count - lfCell.Row + 1)
        Set ldCell = .Find("*", , xlFormulas, , , xlPrevious)
    End With
    
    If ldCell Is Nothing Then
        Set ldCell = lfCell
    Else
        Set ldCell = ldCell.Offset(1)
    End If
    
    ' Note that 'Address:=""' is necessary.
    ' Note the two "'" in 'SubAddress' to cover for names with spaces.
    ldCell.Hyperlinks.Add _
        Anchor:=ldCell, _
        Address:="", _
        SubAddress:="'" & dName & "'!" & dCellAddress, _
        ScreenTip:="", _
        TextToDisplay:=dName
        
    'lws.Select ' visually confirm that the hyperlink was created
    
    MsgBox "Worksheet copied, hyperlink created.", vbInformation
    
End Sub