Thread: macro to create hyperlink for variable worksheet

Hi

I am new to this forum so i hope i am communicating the right thing in order to get help.

So i have an excel file containing a complex plan. This file has an overview sheet and project plans.
In the overview sheet :column A contains a hyperlinks to other worksheets (1 project plan=1 worksheet) column B and C contain status and deadlines (information is taken from the worksheets).

Then i have a small macro that automatically adds an empty plan template and prompts the user to name it.

my challenge is to continue the code with the following
1. make the user select a cell/row in the overview sheet (title of the project has more characters than worksheet) and
2. hyperlink automatically the new project plan (which is a variable) to it and
3. pick up the necessary information for column B and C in the overview sheet from the new project plan (cells 5D and 5E)

Any help would be appreciated. Thank you so much!

andreea_n,

The macro I created assumes the following:
-The cell getting the hyperlink is always the next empty cell in column A
-The new project is always the last worksheet

Let me know if those assumptions are false

Sub NewProjectLink()

    Dim wsNewProject As Worksheet:  Set wsNewProject = Sheets(Sheets.Count)
    Dim rngNewEntry As Range
    If IsEmpty(ActiveSheet.Range("A1")) Then
        Set rngNewEntry = ActiveSheet.Range("A1")
    Else
        Set rngNewEntry = ActiveSheet.Range("A" & Rows.Count).End(xlUp).Offset(1, 0)
    End If
    
    ActiveSheet.Hyperlinks.Add Anchor:=rngNewEntry, _
                               SubAddress:=wsNewProject.Name & "!A1", TextToDisplay:=wsNewProject.Name, _
                               Address:=""
    
    rngNewEntry.Offset(0, 1).Value = wsNewProject.Range("D5").Value
    rngNewEntry.Offset(0, 2).Value = wsNewProject.Range("E5").Value
    
End Sub

Hope that helps,
~tigeravatar

tigeravatar

Thank you for your time and the very quick reply!! That is really cool.

unfortunately i did not explain the hypothesis properly.
projects appear all the time and they are grouped on topics in sheet A. so the user must get prompted to select to which cell he wants to add a workplan.
The cells are not always empty (the time a project plan is added is not identical to when it is decided to be done, namely the time it appears on the overview sheet) this makes then things more complicated.

I hope you could still under the new conditions give this code a try!
thank you!

!!! I also posted the same question on two other forums. (I did not know that it was cross posting)
Here are the links:
http://www.mrexcel.com/forum/showthread.php?t=541900
http://www.ozgrid.com/forum/showthre...86&pagenumber=

andreea_n,

Alright, so with those conditions, it was much trickier. I ended up implementing a userform, and a Worksheet_SelectionChange event. There isn't actually a lot of code, its just spread out. Here's the different sections of code:

First of all, I created a button that I placed on Sheet1 named "New Project Link" and clicking it starts the process of adding a hyperlink to a project.
That button has the following code:

Public CellSelection As Boolean

Sub NewProjectLink()

    Dim Response
    Response = MsgBox(Prompt:="Is the cell you want to add a Link to already selected?", _
                      Title:="New Project Link", Buttons:=vbYesNo)
    
    If Response = vbYes Then
        Run UpdateLink(Selection)
    Else
        MsgBox Prompt:="Click OK, then select the cell to have Link added.", _
               Title:="New Project Link"
        CellSelection = True
    End If
    
End Sub

Basically that code asks the user if the cell he has currently selected is the intended target. If so, it runs the UpdateLink function. If not, it sets the public variable CellSelection to true (used by the Worksheet_SelectionChange event)

Let's pretend the current cell is not the intended target. Now the user has to click the intended cell, which prompts the Worksheet_SelectionChange event:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
    If CellSelection = True Then
        Run UpdateLink(Target)
        CellSelection = False
    End If
    
End Sub

That code only runs if the public variable CellSelection is set to True. After running, it returns CellSelection to false, and then runs the UpdateLink function:

Public Function UpdateLink(Target As Range)
    
    If Target.Cells.Count > 1 Or Left(Target.Address, 2) <> "$A" Then
        MsgBox Prompt:="Invalid selection:" & Chr(10) & _
                       "-Only 1 cell may be selected" * Chr(10) & _
                       "-The selected cell must be in column A", _
               Title:="New Project Link Error"
        Exit Function
    End If
    
    On Error Resume Next
    frm_NewProjectLink.Show
    
End Function

That function checks if the selected cell is valid. In order for the selected cell to be valid, only 1 cell may be selected (if multiple are selected it returns an error) and the selected cell must be in column A (otherwise it returns an error). If the selected cell is valid, it launches the userform.

The userform is very basic. It has a drop-down box that contains the sheetnames in the workbook. User selects one of the sheetnames and clicks the OK button. That will input the hyperlink and copy over the cells 5D and 5E from the target worksheet and put them in column B and C cells (the cells next to the now-hyperlinked cell in Sheet1). Clicking the red X or the Cancel button closes the userform with no hyperlink update. The following is the code for the userform:

Dim wsNames As Worksheet
Dim wsCurrent As Worksheet
Dim rngNewEntry

Private Sub btn_Cancel_Click()

    Unload Me
    
End Sub

Private Sub btn_OK_Click()
    
    Dim strLinkSheet As String: strLinkSheet = Me.cbx_SheetNames.Text
    
    If strLinkSheet = vbNullString Then
        Me.cbx_SheetNames.SetFocus
        MsgBox Prompt:="Select a project to link to.", _
               Title:="New Project Link Error"
        Exit Sub
    End If
    
    Dim strDisplayText As String
    If IsEmpty(rngNewEntry) Then
        strDisplayText = strLinkSheet
    Else
        strDisplayText = rngNewEntry.Value
    End If
    
    wsCurrent.Hyperlinks.Add Anchor:=rngNewEntry, _
                             SubAddress:=strLinkSheet & "!A1", _
                             TextToDisplay:=strDisplayText, _
                             Address:=""
    
    rngNewEntry.Offset(0, 1).Value = Sheets(strLinkSheet).Range("D5").Value
    rngNewEntry.Offset(0, 2).Value = Sheets(strLinkSheet).Range("E5").Value
    
    Unload Me
    
End Sub

Private Sub UserForm_Initialize()
        
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Set rngNewEntry = ActiveCell
    Set wsCurrent = ActiveSheet
    Set wsNames = Sheets.Add(After:=Sheets(Sheets.Count))
    wsNames.Visible = xlSheetHidden
    wsNames.Range("A1").Value = "Worksheet names"
    
    Dim ws As Worksheet
    For Each ws In ThisWorkbook.Worksheets
        If ws.Name <> wsCurrent.Name And ws.Name <> wsNames.Name Then
            wsNames.Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = ws.Name
        End If
    Next ws
    
    If IsEmpty(wsNames.Range("A2")) Then
        MsgBox Prompt:="There are no projects to Link to.", _
               Title:="New Project Link Error"
        Unload Me
    End If
        
    Me.cbx_SheetNames.RowSource = wsNames.Name & "!A2:A" & wsNames.Range("A" & Rows.Count).End(xlUp).Row
    
    wsCurrent.Activate
    Application.ScreenUpdating = True
    
End Sub

Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    
    wsNames.Delete
    Application.DisplayAlerts = True
    
End Sub

I've attached my test workbook in which this was created. Let me know if you have any questions, or if it needs to be adjusted.
~tigeravatar