Two 'Const sURI As String'

E

eli_m

Board Regular
Joined
Jun 2, 2022
Messages
129
Office Version
  1. 365
Platform
  1. Windows
Hi,

I have this code:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI As String = "https://test/cases/"

    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) 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
   
   
        Const sURI As String = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="

    'Conditions for event driven
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("AH3:AH200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

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

        'Add a Hyperlink
        If Target.Value <> "" Then    ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "AH"), Address:= _
                                       sRI & Target.Value, TextToDisplay:=Cells(Target.Row, "AH").Value
        Else
            Cells(Target.Row, "AH").Hyperlinks.Delete    'Delete Hyperlink when AH is empty
        End If
        'Set hyperlink text
        With Cells(Target.Row, "AH").Font
            .Parent.Style = "Normal"    'Added
            .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:AS"))
    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
    Dim r As Range: Set r = Range("A2:AS200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel

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

End Sub

I get the error:
1664511069985.png


I recently added the below and the CODE works if I remove:

VBA Code: 
        Const sURI As String = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="

    'Conditions for event driven
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("AH3:AH200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

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

        'Add a Hyperlink
        If Target.Value <> "" Then    ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "AH"), Address:= _
                                       sRI & Target.Value, TextToDisplay:=Cells(Target.Row, "AH").Value
        Else
            Cells(Target.Row, "AH").Hyperlinks.Delete    'Delete Hyperlink when AH is empty
        End If
        'Set hyperlink text
        With Cells(Target.Row, "AH").Font
            .Parent.Style = "Normal"    'Added
            .Name = "Calibri"
            .Size = 12
            .Bold = True
            .Color = vbBlack
            .Underline = xlUnderlineStyleNone
        End With
    End If

How can I have both of them work?

Thanks in advance
 

Excel Facts

Ambidextrous Undo
Undo last command with Ctrl+Z or Alt+Backspace. If you use the Undo icon in the QAT, open the drop-down arrow to undo up to 100 steps.
Sort by date Sort by votes
Constants are not able to be edited, and thus you have two options:
  1. VBA Code: 
    Const sURI_1 As String = "https://test/cases/"
'.
'.
'.
Const sURI_2 As String = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="

  2. VBA Code: 
    Dim sURI as string
sURI = "https://test/cases/"
'.
'.
'.
sURI = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="
 
Upvote 0
cmowla said:
Constants are not able to be edited, and thus you have two options:
  1. VBA Code: 
    Const sURI_1 As String = "https://test/cases/"
'.
'.
'.
Const sURI_2 As String = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="

  2. VBA Code: 
    Dim sURI as string
sURI = "https://test/cases/"
'.
'.
'.
sURI = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="
Click to expand...

Thanks for your reply!

I tried this and only the sURI_1 worked - what am I missing?

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
    Const sURI_1 As String = "https://test/cases/"

    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) 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_1 & 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
   
   
        Const sURI_2 As String = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="

    'Conditions for event driven
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("AH3:AH200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

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

        'Add a Hyperlink
        If Target.Value <> "" Then    ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "AH"), Address:= _
                                       sURI_2 & Target.Value, TextToDisplay:=Cells(Target.Row, "AH").Value
        Else
            Cells(Target.Row, "AH").Hyperlinks.Delete    'Delete Hyperlink when AH is empty
        End If
        'Set hyperlink text
        With Cells(Target.Row, "AH").Font
            .Parent.Style = "Normal"    'Added
            .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:AS"))
    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
    Dim r As Range: Set r = Range("A2:AS200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel

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

End Sub
 
Upvote 0
Not quite sure. But if you didn't comment out the line:
VBA Code: 
On Error GoTo ErrLine
for helping you to debug/catch the error, that should help.
 
Upvote 0
cmowla said:
Not quite sure. But if you didn't comment out the line:
VBA Code: 
On Error GoTo ErrLine
for helping you to debug/catch the error, that should help.
Click to expand...
Theres no error - it just doesn't hyperlink column AH
 
Upvote 0
I tried the below but only Column A hyperlinks from Column Q but Column AH isn't hyperlinking with data from AH - is anyone able to figure whats wrong?

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

    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("Q3:Q200")) 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
    
    
        sURI = "https://mydhl.express.dhl/au/en/tracking.html#/results?id="

    'Conditions for event driven
    If Target.Count <> 1 Then Exit Sub
    If Not Intersect(Target, Range("AH3:AH200")) Is Nothing Then

        On Error GoTo ErrLine
        Application.EnableEvents = False

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

        'Add a Hyperlink
        If Target.Value <> "" Then    ' If Reference column is NOT blank
            ActiveSheet.Hyperlinks.Add Anchor:=Cells(Target.Row, "AH"), Address:= _
                                       sURI & Target.Value, TextToDisplay:=Cells(Target.Row, "AH").Value
        Else
            Cells(Target.Row, "AH").Hyperlinks.Delete    'Delete Hyperlink when AH is empty
        End If
        'Set hyperlink text
        With Cells(Target.Row, "AH").Font
            .Parent.Style = "Normal"    'Added
            .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:AS"))
    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
    Dim r As Range: Set r = Range("A2:AS200")
    Dim cel As Range

    For Each cel In r
        With cel
            .Errors(8).Ignore = True    'Data Validation Error
            .Errors(9).Ignore = True    'Inconsistent Error
            .Errors(6).Ignore = True    'Lock Error
        End With
    Next cel

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

End Sub
 
Upvote 0
You must log in or register to reply here.

Similar threads

E
  • Question
Auto close spreadsheet timer not working correctly
2
Replies
17
Views
777
eli_m
E
E
  • Question
Hyperlink column data for two columns only working for one
Replies
0
Views
381
eli_m
E
S
  • Solved
Working with multiple Target Ranges in Worksheet Code
Replies
3
Views
375
sspatriots
S
E
  • Question
Issues When Using VBA to Automatically Move Row to Another Sheet Based On Cell Value
2 3
Replies
21
Views
2K
EBe
E
S
  • Question
Worksheet Change Event
Replies
2
Views
379
sspatriots
S

Forum statistics

Threads
1,214,983
Messages
6,122,583
Members
449,089
Latest member
Motoracer88

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