VBA to generate hyperlink to new sheet and assign to shape

[Dunk4Divin]

Hi All

I'm new here so please bear with me if I make a mistake with this post.

I have assembled code (mostly not written myself but altered to suit - I am self taught & not an expert) which copies a sheet

"AltPF Master - Rev 1"​

and allows the user to give the new sheet a name (the sheets are for making flow charts and Sub-Flow Charts and the workbook has all tabs and tool bars hidden, with all tools required made available with buttons etc. hence the need to make and assign the link at the same time as the sheet). The code also adds a shape (circle) to the starting point sheet.

What I have been unable to find anywhere is how to generate a hyperlink

to take the user to the new sheet​

(

using the new name given by the user) ​

and then assign the link to the to the new shape with

text​

inserted to show where the link is going to take the user. The new sheet name is returned in cell B1 of the new sheet and I have started by getting the new name from the sheet (first piece of code below) but am struggling to construct anything that works from that and am unsure if that is even the right way to go.

Any help would be very much appreciated.

Sub getNewAltPFName()

    DimmyValue As Variant
    myValue = ActiveSheet.Range("B1").Value
    MsgBox myValue
End Sub


Sub NewAltPF()
   Sheets("AltPF Master - Rev 1").Select
   Sheets("AltPF Master - Rev 1").Copy Before:=Sheets(1)
    CallUserSaveAndProtectSheetAPF
    CallReNameNewAltPF
End Sub
Sub DeleteNewAltPF()
   Application.DisplayAlerts = False 'switching off the alert button
   Sheets("AltPF Master - Rev 1 (2)").Select
   ActiveWindow.SelectedSheets.Delete
   Application.DisplayAlerts = True 'switching on the alert button
End Sub
Sub ReNameNewAltPF()
Dim mySheetName$
mySheetName = InputBox("Enter proposedsheet name:", "Sheet name")
If mySheetName = "" Then
    MsgBox"You did not enter anything or you hit Cancel.", 64, "No sheetname was entered."
   answer = MsgBox("NOTE: Are you sure you want new a AlternateProcess Flow Sheet. Click Rename Button to continue.", vbYesNo +vbQuestion)
    Ifanswer = vbNo Then
    CallDeleteNewAltPF
    ExitSub
    EndIf
    ExitSub
End If
 
'If the length of the entry is greater than 31characters, disallow the entry.
If Len(mySheetName) > 31 Then
MsgBox "Worksheet tab names cannot begreater than 31 characters in length." & vbCrLf & _
"You entered " & mySheetName& ", which has " & Len(mySheetName) & "characters.", , "Keep it under 31 characters. Click Rename Button tocontinue."
    ExitSub
End If
 
'Sheet tab names cannot contain the characters/, \, [, ], *, ?, or :.
'Verify that none of these characters arepresent in the cell's entry.
Dim IllegalCharacter(1 To 7) As String, i AsInteger
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
 
For i = 1 To 7
If InStr(mySheetName, (IllegalCharacter(i)))> 0 Then
MsgBox "You used a character that violatessheet naming rules." & vbCrLf & vbCrLf & _
"Please re-enter a sheet name without the''" & IllegalCharacter(i) & "'' character." & vbCrLf& vbCrLf & _
"Click the Rename button", 48,"Not a possible sheet name !!"
 
    ExitSub
End If
Next i
 
'Verify that the proposed sheet name does notalready exist in the workbook.
Dim strSheetName As String, wks As Worksheet,bln As Boolean
strSheetName = Trim(mySheetName)
On Error Resume Next
Set wks =ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
 
'History is a reserved word, so a sheet cannotbe named History.
If UCase(mySheetName) = "HISTORY"Then
MsgBox "A sheet cannot be named History,which is a reserved word.", 48, "Not allowed. Click Rename Button tocontinue."
 
    ExitSub
End If
 
'If the worksheet name does not already exist,name the active sheet as the InputBox entry.
'Otherwise, advise the user that duplicatesheet names are not allowed.
If bln = False Then
ActiveSheet.Name = strSheetName
MsgBox "A new blank Alternate Process Flownamed ''" & mySheetName & "'' has been added.", 64,"Done"
Else
MsgBox "There is already a sheet named" & strSheetName & "." & vbCrLf & _
"Please click Rename Button to continue& enter a unique name for this sheet.", 16, "Duplicate sheetnames not allowed. Click Rename Button to continue."
Exit Sub
End If
 
    CallHideRenameButton
    CallDeleteNewAltPF
   Sheets("Process Flow C - Rev 1").Activate
'Add circle shape to starting point sheet    
ActiveSheet.Shapes.AddShape(msoShapeOval, 255,200, 60, 60).Select
Selection.ShapeRange.Fill.Visible = msoTrue
With Selection.ShapeRange.Fill
.ForeColor.RGB = RGB(255, 162, 0)
.Transparency = 0#
End With
Selection.ShapeRange.Name = strSheetName
With Selection.ShapeRange.Line
.Visible = msoTrue
.ForeColor.RGB = RGB(0, 0, 0)
.Transparency = 0
End With
With Selection.ShapeRange.Line
.Visible = msoTrue
.Weight = 1#
End With
End Sub 

 

[pbornemeier]

Modify the indicated one line of your code and add the lines marked as new lines .

Option Explicit

Sub AddShapeWithhyperlink()
    
    Dim mySheetName As String                                                       'Already in your code
    Dim shp As Shape                                                                'New line
    Dim sSubAddress As String                                                       'New line
    
    mySheetName = "Sheet2"                                                          'Not needed when added to your code
    
    Set shp = ActiveSheet.Shapes.AddShape(msoShapeOval, 255, 200, 60, 60)           'Minor change to your code
    shp.Select                                                                      'New line
    sSubAddress = "'" & mySheetName & "'!A1"                                        'New line
    ActiveSheet.Hyperlinks.Add Anchor:=shp, Address:="", SubAddress:=sSubAddress    'New line

End Sub

 

[Dunk4Divin]

Hi Phil

Just returned from holiday and tried your additional code and it works perfectly Thanks, very much appreciated.

 

[pbornemeier]

Glad to help. Thanks for feedback.