Assigning Hyperlink to Cell based up Environment Variable

[g_speran]

I am trying to assign a hyperlink function to a cell, as follow, using VBA code
=HYPERLINK(env("OneDriveCommercial") & "\..\DPS\Engagements\Mary\PR-00000", PR-00000)

The Windows Environment Variable is OneDriveCommercial
- OneDriveCommercial=C:\Data\Collection\OneDrive\Active

I have a defined function called env

My VBA code works to a Point but not completely. When assigning the hyperlink function to the cell value, I am getting atsigns (@) which is not expected
=HYPERLINK(@env("OneDriveCommercial") &@ PathAdd,@ TargetValue)

For all intended purposes, the excel spreadsheet would have
cell(r,2)="Mary"
cell (r,5)="PR-00000"

Goal: Execute Code from any cell in the row and For Cell (R,5) to display the Hyperlink Friendly Name but contain the Hyperlink formula/function

The VBA code is below. Any assistance is appreciated in rectifying my cell value

Sub MakeFolders_Hyperlink2()
        Dim Rng As Range
        Dim TargetDir, TargetPath, ENVPath, PathAdd As String
        Dim TargetValue As String
        Dim iStart, answer  As Integer
        Dim aDirs           As Variant
        Dim sCurDir         As String
        Dim i, r            As Integer
        Dim fld, myFile     As Object
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Set Rng = ActiveCell
        Set fld = CreateObject("Scripting.FileSystemObject")
        r = Rng.Row
        TargetValue = Cells(r, 5)
        TargetColor = Cells(r, 5).Font.Color
        ENVPath = (env("OneDriveCommercial"))
        PathAdd = "\..\DPS\Engagements\" & Cells(r, 2) & "\" & TargetValue
        TargetPath = ENVPath & PathAdd
        
            If Len(Dir(TargetPath, vbDirectory)) = 0 Then
               If TargetPath <> "" Then
                   aDirs = Split(TargetPath, "\")
                   If Left(TargetPath, 2) = "\\" Then
                       iStart = 3
                   Else
                       iStart = 1
                   End If
            
                   sCurDir = Left(TargetPath, InStr(iStart, TargetPath, "\"))
            
                   For i = iStart To UBound(aDirs)
                       sCurDir = sCurDir & aDirs(i) & "\"
                       If Dir(sCurDir, vbDirectory) = vbNullString Then
                           MkDir sCurDir
                       End If
                   Next i
                   ActiveSheet.Cells(r, 5).Formula = "=HYPERLINK(env(""OneDriveCommercial"") & PathAdd, TargetValue)"
                        ' ==> attempts to execute env function and do not want it to <==
                        ' ==> want cell (r,5) to be =HYPERLINK(env("OneDriveCommercial") & "\..\DPS\Engagements\Mary\PR-00000", PR-00000)
                   Cells(r, 5).Font.Color = TargetColor
                   Set myFile = fld.CreateTextFile(TargetPath & "\Notes.txt", False)
               End If
            Else
                answer = MsgBox("Directory " & TargetPath & " Already exists", vbQuestion + vbYesNo + vbDefaultButton2, "Create Hyperlink")
                If answer = vbYes Then
                    ActiveSheet.Cells(r, 5).Formula = "=HYPERLINK(env(""OneDriveCommercial"") & PathAdd, TargetValue)"
                        ' ==> attempts to execute env function and do not want it to
                        ' ==> want cell (r,5) to be =HYPERLINK(env("OneDriveCommercial") & "\..\DPS\Engagements\Mary\PR-00000", PR-00000)
                    Cells(r, 5).Font.Color = TargetColor
                End If
            End If
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
End Sub

    Function env(vn As String) As String
      env = Environ(vn)
    End Function

 

[g_speran]

Correct. The \..\ is used to go back one directory

Tried the above code and set the at sign as well
=HYPERLINK(@env("TEMP")&"\gotcha.txt","click me")

 

[g_speran]

I do want to give an update on this.
I now looks like the code is working. One thing i noticed today was that no cells were automatically updating if they contained a function. this was rectified by Formulas==>Calculation Options==>Automatic

So, eventhough the code return @ in-front of env in the formula, it now operates as expected

Sub MakeFolders_Hyperlink2()
        Dim Rng As Range
        Dim TargetDir, TargetPath, ENVPath, PathAdd As String
        Dim TargetValue As String
        Dim iStart, answer  As Integer
        Dim aDirs           As Variant
        Dim sCurDir         As String
        Dim i, r            As Integer
        Dim fld, myFile     As Object
        Application.ScreenUpdating = False
        Application.Calculation = xlCalculationManual
        Set Rng = ActiveCell
        Set fld = CreateObject("Scripting.FileSystemObject")
        r = Rng.Row
        TargetValue = Cells(r, 5)
        TargetColor = Cells(r, 5).Font.Color
        ENVPath = (Environ("OneDriveCommercial"))
        PathAdd = "\..\DPS\Engagements\" & Cells(r, 2) & "\" & TargetValue
        TargetPath = ENVPath & PathAdd
        NewFormula = "=HYPERLINK(env(""OneDriveCommercial"")&""" & PathAdd & """,""" & TargetValue & """)"
        
            If Len(Dir(TargetPath, vbDirectory)) = 0 Then
               If TargetPath <> "" Then
                   aDirs = Split(TargetPath, "\")
                   If Left(TargetPath, 2) = "\\" Then
                       iStart = 3
                   Else
                       iStart = 1
                   End If
            
                   sCurDir = Left(TargetPath, InStr(iStart, TargetPath, "\"))
            
                   For i = iStart To UBound(aDirs)
                       sCurDir = sCurDir & aDirs(i) & "\"
                       If Dir(sCurDir, vbDirectory) = vbNullString Then
                           MkDir sCurDir
                       End If
                   Next i
                   'ActiveSheet.Cells(r, 5).Formula = "=HYPERLINK(env(""OneDriveCommercial"") & PathAdd, TargetValue)"
                   ActiveSheet.Cells(r, 5).Formula = NewFormula
                   Cells(r, 5).Font.Color = TargetColor
                   Set myFile = fld.CreateTextFile(TargetPath & "\Notes.txt", False)
               End If
            Else
                answer = MsgBox("Directory " & TargetPath & " Already exists", vbQuestion + vbYesNo + vbDefaultButton2, "Create Hyperlink")
                If answer = vbYes Then
                    'ActiveSheet.Cells(r, 5).Formula = "=HYPERLINK(env(""OneDriveCommercial"") & PathAdd, TargetValue)"
                    ActiveSheet.Cells(r, 5).Value = NewFormula
                    Cells(r, 5).Font.Color = TargetColor
                End If
            End If
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
    End Sub

Function env(vn As String) As String
  env = Environ(vn)
End Function

 

[Joe4]

I now looks like the code is working. One thing i noticed today was that no cells were automatically updating if they contained a function. this was rectified by Formulas==>Calculation Options==>Automatic

Note that you have this line near the beginning of your code:

       Application.Calculation = xlCalculationManual

This turns off automatic calculations. This is often done in VBA code that makes a lot of changing, in order to speed it up. Calculations and screen updating are often temporarily paused until the end of the code to help reduce screen flickering and speed up the code.

You can see this line near the botton of your code to turn it back on:

        Application.Calculation = xlCalculationAutomatic

So what often happens when you are building/testing your code, is that maybe you have an error in your code that stops your code run halfway through. So, it shut off automatic calculations, but never got to the line to turn them back on again. If you don't notice that happened, you can start to see apparent weirdness like this, where things don't seem to be working as they should (or as they were before), but once you understand why, it makes perfect sense.

If this happens, you can create a little procedure to turn this items back on again, and just run it so you can continue building/testing, i.e.

Sub TurnThemOnAgain()
        Application.ScreenUpdating = True
        Application.Calculation = xlCalculationAutomatic
End Sub

 

[GWteB]

@g_speran, thanks for the update and note @Joe4's suggestion.

 

[g_speran]

wanted to update this as I have gotten it to work. SOrry i never responded with the functionong code

sub Test_Hyperlink()
Dim Rng As Range
Dim r as integer
Dim PathAdd As String, HYPERformula as string, TargetValue As String

Set Rng = ActiveCell
r = Rng.row

TargetValue = Cells(r, 5)
PathAdd = "\[Path1]\[Path2]\[Path3]\" & Cells(r, 2) & "\" & TargetValue
HYPERformula = "=HYPERLINK(env(""USERPROFILE"")&""" & PathAdd & """,""" & TargetValue & """)"

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual

ActiveSheet.Cells(r, 5).Formula = HYPERformula

Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
end sub

Private Function env(vn As String) As String
env = Environ(vn)
End Function

Immediate Windows
?r
76
?targetvalue
PR-00002
?pathadd
\[Path1]\[Path2]\[Path3]\[value of Cell row 76,col 2]\PR-00002
?Hyperformula
=HYPERLINK(env("USERPROFILE")&"\[Path1]\[Path2]\[Path3]\[value of Cell row 76,col 2]\PR-00002","PR-00002")