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
160
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
 

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.
Sort by date Sort by votes
You are exiting the sub if the target is not in column U

For test purposes
put a STOP instruction as the first line in the sub
when code execution stops at that point
use the F8 key to step one line at a time thru the code and see where it goes
 
Upvote 0
NoSparks said:
You are exiting the sub if the target is not in column U

For test purposes
put a STOP instruction as the first line in the sub
when code execution stops at that point
use the F8 key to step one line at a time thru the code and see where it goes
Click to expand...
Thanks for that! It Exits the Sub in the next line even though only cell AC166 is selected and is a date.
1732662140388.png

How would I fix that?


Also, how can I continue onto the next part instead of exiting/stopping?
 
Upvote 0
try something along the lines of this to keep the code continuing
VBA Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'  Deal with selection of only one cell
    If Target.CountLarge > 1 Then Exit Sub

'Check Timeout timer
    checktime = True
    Lastchange = Now()

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

If Not Intersect(Target, Range("U:U")) Is Nothing Then
    ' your code to do whatever is needed
    ' when selection is in column U
End If

If Not Intersect(Target, Range("AC3:AC200")) Is Nothing Then
    ' your code to do whatever is needed
    ' when selection is in column AC
End If

End Sub
 
Upvote 0
NoSparks said:
try something along the lines of this to keep the code continuing
VBA Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'  Deal with selection of only one cell
    If Target.CountLarge > 1 Then Exit Sub

'Check Timeout timer
    checktime = True
    Lastchange = Now()

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

If Not Intersect(Target, Range("U:U")) Is Nothing Then
    ' your code to do whatever is needed
    ' when selection is in column U
End If

If Not Intersect(Target, Range("AC3:AC200")) Is Nothing Then
    ' your code to do whatever is needed
    ' when selection is in column AC
End If

End Sub
Click to expand...

Firstly, thank you so much for helping me with this.

I tried what you said and I still can't get it to work - There is no errors but this part of the code doesn't work anymore:
VBA Code: 
    Set Changed = Intersect(Target, Columns("A:AQ"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If

'Ignore Errors with Worksheet Clicks
Call IgnoreErrors


Full code:
VBA Code: 
Option Explicit
' Ignore Errors when Worksheet Activated
Private Sub Worksheet_Activate()
'Start Timeout Timer
checktime = False
Call checktimer
'Check Timeout timer
checktime = True
Lastchange = Now()

Dim r As Range: Set r = Range("A2:AQ200")
Dim cel As Range

End Sub

Private Sub Worksheet_Deactivate()
 checktime = False 'Stop Timeout timer so it can stay open when on other sheets
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'  Deal with selection of only one cell
    If Target.CountLarge > 1 Then Exit Sub

'Check Timeout timer
    checktime = True
    Lastchange = Now()

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

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

If Not Intersect(Target, Range("AC3:AC200")) Is Nothing Then
    If Not 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
            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 = xlUnderlineStyleNone
        End With
        End If
    End If
End If

End Sub

Private Sub Worksheet_Calculate()

Call IgnoreErrors ' Ignore Errors after Sorting

End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://gate.com/ui/cases/"

    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("S3:S200")) Is Nothing Then

        On Error GoTo ErrLine
        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, "A"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete
        End If
 
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal"
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .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

    ' Copy from Line 200 into deleted cells
    Dim Changed As Range, c As Range

    Set Changed = Intersect(Target, Columns("A:AQ"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If

'Ignore Errors with Worksheet Clicks
Call IgnoreErrors 

    
ErrLine:        'Just in case, enable event
    Application.EnableEvents = True
    


End Sub
 
Upvote 0
Appears you're wanting to work with a range of cells.
The second line in your Worksheet_Change event
exits the sub if Target.count is not equal to 1
 
Upvote 0
NoSparks said:
Appears you're wanting to work with a range of cells.
The second line in your Worksheet_Change event
exits the sub if Target.count is not equal to 1
Click to expand...
I only want to work with one cell at a time so it shouldn't exit
 
Upvote 0
NoSparks said:
Sorry I can't follow what you're doing at all.
Click to expand...
I'll try and break it down into subs as the below code is working great but when I add the extra part it doesn't work:


Worksheet_Change:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://gate.com/ui/cases/"

    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("S3:S200")) Is Nothing Then

        On Error GoTo ErrLine
        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, "A"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "A").Value
        Else
            Cells(Target.Row, "A").Hyperlinks.Delete
        End If
 
        With Cells(Target.Row, "A").Font
            .Parent.Style = "Normal"
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .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

    ' Copy from Line 200 into deleted cells
    Dim Changed As Range, c As Range

    Set Changed = Intersect(Target, Columns("A:AQ"))
    If Not Changed Is Nothing Then
        Application.EnableEvents = False
        For Each c In Changed
            If Len(c.Text) = 0 Then Cells(200, c.Column).Copy Destination:=c
        Next c
        Application.EnableEvents = True
    End If

Call IgnoreErrors 'Ignore Errors with Worksheet Clicks
    
ErrLine:        'Just in case, enable event
    Application.EnableEvents = True
 
End Sub


Worksheet_SelectionChange:
VBA Code: 
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

'Check Timeout timer
checktime = True
Lastchange = Now()

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

If Intersect(Target, Range("U:U")) Is Nothing Or Target.Count > 1 Then GoTo CaseLink
    If Not Target.Find("Create Calendar Invite", LookIn:=xlValues) Is Nothing Then
        Call CalendarInvite.CalendarInvite
End If

End Sub


But for some reason when I added the below code to Worksheet_SelectionChange It doesn't turn my cell into a hyperlink:
VBA Code: 
CaseLink:
If Not Intersect(Target, Range("AC3:AC200")) Is Nothing Then
    If Not 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
            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 = xlUnderlineStyleNone
        End With
        End If
    End If
End If
 
Upvote 0
Sorry, perhaps another forum member will be able to help.
 
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
110
Fluff
Fluff
E
  • Question Question
Copy Cell as Hyperlink to another cell
Replies
1
Views
323
eli_m
E
J
  • Question Question
Copying Rows Based on Column Value
Replies
1
Views
213
jolivanes
jolivanes
S
  • Question Question
Excel VBA Help
Replies
1
Views
118
DanteAmor
DanteAmor
K
  • Question Question
VBA Code for User log history
2 3
Replies
21
Views
547
Logit
Logit

Forum statistics

Threads
1,225,156
Messages
6,183,229
Members
453,152
Latest member
ChrisMd

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