VBA - If Cell IsDate and Another Column is a formula then make Cell a hyperlink

[eli_m]

Hi,

I currently have the below code where if I edit any cell in Column AC to a date and ActiveCell.Row AK is a formula, I want it to make the date in Column AC a hyperlink that goes to:

https://case.com/cases/Cells(ActiveCell.Row, "BU").Value

I'm not getting any errors when I change the cell to a date or to any other value so I am not sure where I am going wrong:

' Column AC - CASE Hyperlink

If Intersect(Target, Range("AC:AC")) Is Nothing Or Target.Count > 1 Then Exit Sub

    If IsDate(Target.Value) And Cells(ActiveCell.Row, "AK").HasFormula Then

    

    Const CaseURL As String = "https://case.com/cases/"



    If Not Intersect(Target, Range("AC3:AC200")) Is Nothing Then



                Application.EnableEvents = False



        With ActiveWorkbook.Styles("Followed Hyperlink").Font

            .Color = RGB(0, 0, 0)

        End With



        If Target.Value <> "" Then

            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "AC"), Address:= _

                                       CaseURL & Cells(ActiveCell.Row, "BU").Value, TextToDisplay:=Target.Value

        Else

            Cells(Target.Row, "AC").Hyperlinks.Delete

        End If

 

        With Cells(Target.Row, "AC").Font

            .Parent.Style = "Normal"

            .Name = "Calibri"

            .Size = 12

            .Bold = False

            .Color = vbBlack

            .Underline = xlUnderlineStyleNone

        End With

    End If



    If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub    'Exit code if whole columns are edited

Full Sub:

Private Sub Worksheet_SelectionChange(ByVal Target As Range)



'Check Timeout timer

checktime = True

Lastchange = Now()





' Refresh for Grey Line

If Application.CutCopyMode = False Then

Application.Calculate

End If





' Column R - Calendar Invite

If Intersect(Target, Range("U:U")) Is Nothing Or Target.Count > 1 Then Exit Sub

    If Not Target.Find("Create Calendar Invite", LookIn:=xlValues) Is Nothing Then

        Call CalendarInvite.CalendarInvite

End If



' Column AC - CASE Hyperlink

If Intersect(Target, Range("AC:AC")) Is Nothing Or Target.Count > 1 Then Exit Sub

    If IsDate(Target.Value) And Cells(ActiveCell.Row, "AK").HasFormula Then

    

    Const CaseURL As String = "https://case.com/cases/"



    If Not Intersect(Target, Range("AC3:AC200")) Is Nothing Then



                Application.EnableEvents = False



        With ActiveWorkbook.Styles("Followed Hyperlink").Font

            .Color = RGB(0, 0, 0)

        End With



        If Target.Value <> "" Then

            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "AC"), Address:= _

                                       CaseURL & Cells(ActiveCell.Row, "BU").Value, TextToDisplay:=Target.Value

        Else

            Cells(Target.Row, "AC").Hyperlinks.Delete

        End If

 

        With Cells(Target.Row, "AC").Font

            .Parent.Style = "Normal"

            .Name = "Calibri"

            .Size = 12

            .Bold = False

            .Color = vbBlack

            .Underline = xlUnderlineStyleNone

        End With

    End If



    If Target.CountLarge / Rows.Count = Int(Target.CountLarge / Rows.Count) Then Exit Sub    'Exit code if whole columns are edited

    

End If





End Sub

 

[Alex Blakenburg]

What happens if you add the line in blue where I have it:
(You are currently turning it off and not back on again)

        End With
        End If
        Application.EnableEvents = True
    End If
End If

Also assuming your code snippet is how it actually how it looks select the code below and hit Shift+Tab moving the indent 1 tab to the left:

    If Not Intersect(Target, Range("AC3:AC200")) Is Nothing Then

        Application.EnableEvents = False

        With ActiveWorkbook.Styles("Followed Hyperlink").Font
            .Color = RGB(0, 0, 0)
        End With