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

E

eli_m

Board Regular
Joined
Jun 2, 2022
Messages
164
Office Version
  1. 365
Platform
  1. Windows
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:




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:





VBA Code: 
' 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:

VBA Code: 
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
 
Sort by date Sort by votes
What happens if you add the line in blue where I have it:
(You are currently turning it off and not back on again)
Rich (BB code): 
        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:
Rich (BB code): 
    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
 
Upvote 0
Alex Blakenburg said:
What happens if you add the line in blue where I have it:
(You are currently turning it off and not back on again)
Rich (BB code): 
        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:
Rich (BB code): 
    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
Click to expand...
I think this did the trick! Thanks for that but I am getting this error when more than one cell is selected and includes Column AC:

What I did (Highlight a row from AA to AC:
1739490408638.png


Error I get:
1739490508858.png

1739490527145.png



Is there a way to fix this?
 
Upvote 0
Selecting more than one cell is inconsistent with post #7:
eli_m said:
I only want to work with one cell at a time so it shouldn't exit
Click to expand...
The exit with Target.Count > 1 was previously there to stop that error from happening.
If you want to work with multiple cells we are going to need to loop through the selected cells that are in column AC.
Is that what you want ?
 
Upvote 0
Alex Blakenburg said:
Selecting more than one cell is inconsistent with post #7:

The exit with Target.Count > 1 was previously there to stop that error from happening.
If you want to work with multiple cells we are going to need to loop through the selected cells that are in column AC.
Is that what you want ?
Click to expand...
Thanks again for your help! If multiple cells are selected I just want it to do nothing. Where would I put the exit in this:
VBA Code: 
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
 
Upvote 0
Alex Blakenburg said:
As early in the code as possible. If you are using Dim statements straight after that.
@NoSparks's post 4 has it right at the top.
Click to expand...
Thanks again for sticking by me with this.

I have tried to make the code easier to understand (for me) so I've turned the formula for Column AC into a Module (CaseLink) that gets called here:
VBA Code: 
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

' Exit if more than one cell is selected
If Target.CountLarge > 1 Then Exit Sub
    

' Create Calendar Invite
If Intersect(Target, Range("U:U")) Is Nothing Then

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

End Sub


CaseLink.CaseLink code:

VBA Code: 
Sub CaseLink()

 If Not Split(Cells(1, ActiveCell.Column).Address, "$")(1) = "AC" Then Exit Sub
 
    If Not IsDate(Target.Value) And Cells(ActiveCell.Row, "AK").HasFormula Then
        
    Const CaseURL As String = "https://case.com/cases/"

        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
            Call IgnoreErrors
        Else
            Cells(Target.Row, "AC").Hyperlinks.Delete
            Call IgnoreErrors
        End If
 
        With Cells(Target.Row, "AC").Font
            .Parent.Style = "Normal"
            .Name = "Calibri"
            .Size = 12
            .Bold = False
            .Color = vbBlack
            .Underline = xlUnderlineStyleSingle
            Cells(Target.Row, "AC").HorizontalAlignment = xlLeft
            Cells(Target.Row, "AC").NumberFormat = "dd-mmm-yy"
        End With
        End If
        
        Application.EnableEvents = True
End Sub

But I am getting this error:
1740028625239.png

1740028671358.png


even though the "AC" cell NOT a Date but a formula:
1740028697575.png


and the "AK" cell has a formula:
1740028769266.png



Where could this error be coming from?
 

Attachments

  • 1740025839496.png
    1740025839496.png
    40.8 KB · Views: 0
Upvote 0
I am not a big fan of using both Target and ActiveCell in the one module. They are generally referring to the same cell.
In your code you are handing over to the sub CaseLink which does not know what Target means.
Ideally you would pass Target as a parameter to CaseLink.
If you want a quick and dirty fix then just select all the code in CaseLink and Replace Target with ActiveCell.
 
Upvote 0
Alex Blakenburg said:
I am not a big fan of using both Target and ActiveCell in the one module. They are generally referring to the same cell.
In your code you are handing over to the sub CaseLink which does not know what Target means.
Ideally you would pass Target as a parameter to CaseLink.
If you want a quick and dirty fix then just select all the code in CaseLink and Replace Target with ActiveCell.
Click to expand...
I wanted to test it over a few days and it seems quick and dirty did the trick!

I was just wondering if there was a better way to code this:
VBA Code: 
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

' Exit if more than one cell is selected
If Target.CountLarge > 1 Then Exit Sub

' CaseLink - Confirm - Column AJ
    If Not Intersect(Target, Range("AJ:AJ")) Is Nothing Then
            Call CaseLink_Check.CaseLink_Check
    End If


' CaseLink - Confirm - Column AC
    If Not Intersect(Target, Range("AC:AC")) Is Nothing Then
            Call CaseLink_Confirm.CaseLink_Confirm
    End If

' Create Calendar Invite - Column U Only
    If Not Intersect(Target, Range("U:U")) Is Nothing Then
        If InStr(ActiveCell.Value, "Create Calendar Invite") > 0 Then
            Call CalendarInvite.CalendarInvite
    End If


End If

End Sub

Basically, I always want it to run this section:
VBA Code: 
'Check Timeout timer
checktime = True
Lastchange = Now()

' Refresh for Grey Line
If Application.CutCopyMode = False Then
Application.Calculate
End If

' Exit if more than one cell is selected
If Target.CountLarge > 1 Then Exit Sub

But if count is Less Than 1 then I want it to run the rest without stopping:

VBA Code: 
' CaseLink - Confirm - Column AJ
    If Not Intersect(Target, Range("AJ:AJ")) Is Nothing Then
            Call CaseLink_Check.CaseLink_Check
    End If

Then:
VBA Code: 
' CaseLink - Confirm - Column AC
    If Not Intersect(Target, Range("AC:AC")) Is Nothing Then
            Call CaseLink_Confirm.CaseLink_Confirm
    End If

Then:
VBA Code: 
' Create Calendar Invite - Column U Only
    If Not Intersect(Target, Range("U:U")) Is Nothing Then
        If InStr(ActiveCell.Value, "Create Calendar Invite") > 0 Then
            Call CalendarInvite.CalendarInvite
    End If

I had to reverse the order to check Column AJ then AC then U because if I checked it in reverse it wouldn't run the rest of it so I am thinking there must be a better way
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Locked
  • Question Question
VBA - If Cell IsDate and Another Column is a formula then make Cell a hyperlink
Replies
2
Views
203
Fluff
Fluff
E
  • Question Question
Copy Cell as Hyperlink to another cell
Replies
1
Views
363
eli_m
E
K
  • Solved
VBA multiple target.column
Replies
7
Views
176
Joe4
Joe4
D
  • Question Question
Locking of cells after not working
2
Replies
11
Views
318
Dazzatron
D
J
  • Question Question
Copying Rows Based on Column Value
Replies
1
Views
364
jolivanes
jolivanes

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top