Inserting hyperlink to folder created with VBA EXCEL-CodePudding

The below code is to create a new folder and name it on the list of names on Column "A", and if it doesn't have "OK" on Column "H" it will not create that folder. Now, I am trying to make it so that it would create a "DONE" message in Column "I" that is hyperlinked to the folder created.

Sub NewFolder()
    Dim R_EmptyLines, R_Line  As Integer

    R_EmptyLines = 0
    R_Line = 2

    
    
    Dim fso As Object
    Dim fldrname As String
    Dim fldrpath As String
    Dim EIposition As String
    Dim Remark_note As String
    
    
    
    
    
    While R_EmptyLines < 10
    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = UCase(Trim(Range("A" & Trim(Str(R_Line)))))
    fldrpath = "C:\TEST\FOLDER\" & fldrname
    EIposition = Range("H" & Trim(Str(R_Line)))
            If Len(fldrname) < 7 Then
               R_EmptyLines = R_EmptyLines   1
            Else
               R_EmptyLines = 0
            If EIposition = "OK" Then
                    If Not fso.FolderExists(fldrpath) Then
                    fso.createfolder (fldrpath)
   '- - - - - - - - - - - - - - - - - - - - - - - -
                    Range("I" & Trim(Str(R_Line))) = ActiveSheet.Hyperlinks.Add , Address:= _
        fldrpath, TextToDisplay:="DONE"
   '- - - - - - - - - - - - - - - - - - - - - - - -
                     End If

                 End If
                 End If
    R_Line = R_Line   1
       Wend
       
   Exit Sub
End Sub

CodePudding user response：

Soooo may things wrong here

Here's your code, refactoed to correct many errors and sub-optimal issues

Sub NewFolder()
    Dim R_EmptyLines As Long, R_Line As Long ' unspecified types will be Variant. No reason to use Integer.
    Dim BasePath As String ' make it easier to maintain
    Dim ws As Worksheet ' use a variable for the worksheet

    BasePath = "C:\TEST\FOLDER\"
    Set ws = ActiveSheet ' or specifiy a specific sheet
    
    R_EmptyLines = 0
    R_Line = 2
    
    Dim fso As Object
    Dim fldrName As String
    Dim fldrPath As String
    Dim EIposition As String
    
    Set fso = CreateObject("scripting.filesystemobject")
    Do While R_EmptyLines < 10 ' don'tuse to obsolete While/Wend?
        fldrName = Trim(ws.Cells(R_Line, 1).Value2) '  Cells avoid unnecassary string constructs.  Be explicit on extracting the cell value.  FSO is not case sensitive
        If Len(fldrName) < 7 Then
            R_EmptyLines = R_EmptyLines   1
        Else
            fldrPath = BasePath & fldrName
            EIposition = ws.Cells(R_Line, 8).Value2 '"H"
            R_EmptyLines = 0
            If EIposition = "OK" Then
                If Not fso.FolderExists(fldrPath) Then
                    fso.createfolder fldrPath ' No need to force evaluation of fldrPath.  Its already a value
                End If
                With ws.Cells(R_Line, 9)
                    ' if Hyperlink already exists, delete it
                    If .Hyperlinks.Count > 0 Then
                        .Hyperlinks.Delete
                    End If
                End With
                ' add hyperlink regardless of if folder already exists
                ws.Hyperlinks.Add Anchor:=ws.Cells(R_Line, 9), Address:=fldrPath, TextToDisplay:="DONE" ' If you're going to use Named Parameters, be consistent
            End If
        End If
        R_Line = R_Line   1
    Loop
End Sub

CodePudding user response：

Finally manage to make it work. I just placed the Range wrongly

If Not fso.FolderExists(fldrpath) Then
fso.createfolder (fldrpath)
ActiveSheet.Hyperlinks.Add Range("I" & Trim(Str(R_Line))), Address:=fldrpath, TextToDisplay:="DONE"
End If