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/[B]Cells(ActiveCell.Row, "BU").Value[/B]

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

 

[eli_m]

Bump

 

[Fluff]

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

In future, please do not post the same question multiple times. Per Forum Rules (#12), posts of a duplicate nature will be locked or deleted.

In relation to your question here, I have closed this thread so please continue in the linked thread.