Trying to automatically add Hyperlink, to newly automated sheet from "Main" sheet?

user_18058537 0
Viewed 19

Hope everyones well.

Im trying to develop a project log for our small business. I have found a quick clever way to just use small pop-upbox to input the smallest necessary information req. (name of the project) to copy a hidden sheet (here called "offert") and replicate that to a new one with a new input name.

  • What im trying to do (and have tried Hyperlink.add etc in various forms) would like that newly, user-input name, to be added as a hyperlink on the "main" sheet here called "offertliggare" in the code, whenever a new sheet is created. Those new links should then fill downwards from say cell A3 in the mainsheet and down.

I have tried in various forms, and tried to study in on vba as well deeper and searched other threads but cant find a solution. Any help would be most appreciated, thanks.

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
hyperlink vba excel
1 Answers

Copy Worksheet and Add Hyperlink

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
user_98140690
Related