Message Box with Hyperlink

[Craig_320]

Hi,
I have tried piecing together from various bits of code but getting in a mess if someone could please help!

I have a drop down Yes/No box within a cell and when a 'No' value is selected I would like a message box to appear with Yes/No answers, where No returns the user back to the sheet and yes takes them to a website hyperlink, is this possible?

Thanks in advance!

 

[My Aswer Is This]

Edit

 

[My Aswer Is This]

Assuming your drop down cell is Range("A1") then try this:
If not "A1" then modify this script
You will also have to modify the message and the link you want to be taken to.
This is an auto sheet event script
Your Workbook must be Macro enabled
To install this code:
Right-click on the sheet tab
Select View Code from the pop-up context menu
Paste the code in the VBA edit window

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim ans As String
If Target.Value = "No" Then
answer = MsgBox("Do tou want to go to your link", vbYesNo + vbQuestion, "Empty Sheet")
Target.Value = "Yes"
    If answer = vbYes Then
        Link = "http://www.nascar.com/en_us/sprint-cup-series/schedule.html"
        On Error GoTo NoCanDo
        ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
    Exit Sub
NoCanDo:
    MsgBox "Cannot open " & Link
End If
End If
End If
End Sub

 

[Craig_320]

Thanks for this, just one little query, if they choose not to follow the link I still need the cell value to stay as No, currently if I select No on the message box it corrects the cell to yes, and when I tweaked the code to say no instead it left me in an infinite loop!

Thanks in advance

 

[My Aswer Is This]

Try this:

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim ans As String
If Target.Value = "No" Then
answer = MsgBox("Do tou want to go to your link", vbYesNo + vbQuestion, "Empty Sheet")
    If answer = vbYes Then
        Link = "http://www.nascar.com/en_us/sprint-cup-series/schedule.html"
        On Error GoTo NoCanDo
        ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
    Exit Sub
NoCanDo:
    MsgBox "Cannot open " & Link
End If
End If
End If
End Sub

 

[Craig_320]

That's spot on thank you!
Is there a way I can have more than one on the same page, i.e. a different message box with a different hyperlink linked to a different cell reference?

Thanks

 

[My Aswer Is This]

So how many more. Will it be just one or two more or dozens.
Will these all be in the same column or scattered all over?
Just trying to get a feel for how to do this.
It can be done but if your talking about dozens more then I need to take a different approach on writing the script.

 

[Craig_320]

Hi

It would only be two message boxes, they are in the same column one row above the other.

Thanks very much

 

[My Aswer Is This]

Try this:
Assuming "No" in ("A1") Or ("A2") Modify to your needs

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("A1")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
Dim ans As String
If Target.Value = "No" Then
answer = MsgBox("Do tou want to go to your link", vbYesNo + vbQuestion, "Empty Sheet")
    If answer = vbYes Then
        Link = "http://www.nascar.com/en_us/sprint-cup-series/schedule.html"
        On Error GoTo NoCanDo
        ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
    Exit Sub
    MsgBox "Cannot open " & Link
End If
End If
End If
'Next Message Box
If Not Intersect(Target, Range("A2")) Is Nothing Then
If Target.Cells.Count > 1 Or IsEmpty(Target) Then Exit Sub
If Target.Value = "No" Then
answer = MsgBox("Do tou want to go to your link", vbYesNo + vbQuestion, "Empty Sheet")
    If answer = vbYes Then
        
        Link = "https://www.mrexcel.com/forum/"
        On Error GoTo NoCanDo
        ActiveWorkbook.FollowHyperlink Address:=Link, NewWindow:=True
    Exit Sub
NoCanDo:
    MsgBox "Cannot open " & Link
End If
End If
End If
End Sub

 

[Craig_320]

Spot on, just the job! Thank you very much!