Create Folder and subfolder along with hyperlink on cell based on cell data-CodePudding

Hope all are fine.

I searched in many forums to find a solution to the problem I am facing. I am describing below. Hope someone will help me. I need a code for the below condition. First of all the code checks for the folder and subfolder. If not exist then, Create folder name based on Cell value E9:E1200, Create a Subfolder name based on the Cell values I and H. If the Folder and subfolder exist then exit. Also, create the hyperlink to that subfolder.

I am currently using the below code, which creates the same except subfolder. I tried to change it but failed.

Sub DownArrow8_Click()
Dim Path As String
Dim Folder As String

For CheckingCells = 9 To 1200
CheckingValue = Cells(CheckingCells, 5).Value
CheckingValueAdress = Cells(CheckingCells, 5).Address

 Path = "E:\2. Bill\" & CheckingValue

 Folder = Dir(Path, vbDirectory)
 
 If CheckingValue = vbNullString Then
 ElseIf Folder = vbNullString Then
 VBA.FileSystem.MkDir (Path)
 Range(CheckingValueAdress).Select
 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="E:\2. Bill\" & CheckingValue, _
 TextToDisplay:=CheckingValue
 
 Else
 Range(CheckingValueAdress).Select
 ActiveSheet.Hyperlinks.Add Anchor:=Selection, Address:="E:\2. Bill\" & CheckingValue, _
 TextToDisplay:=CheckingValue

 End If
Next CheckingCells

With Range("e9:e1200").Font
 .ColorIndex = x1Automatic
 .Underline = xlUnderlineStyleNone
 .Name = "Times New Roman"
 .Size = 18
End With
End Sub

Hope someone helps will be appreciated.

Thanks in Advance.

CodePudding user response：

If you attempt to create a subfolder within a folder that doesn't exist, you'll run into an error. You need to loop through the path, and try to create each missing folder one by one. Here is an example of a function that will do that:

Sub DownArrow8_Click()
    Dim Path As String
    Dim Folder As String
    
    Dim WS As Worksheet
    Set WS = ActiveSheet
    
    Dim Row As Range
    For Each Row In WS.Range("9:1200").EntireRow.Rows
        Dim CheckingCell As Range
        Set CheckingCell = Row.Cells(5)
        
        Path = "E:\2. Bill\" & CheckingCell.Value
        
        'Creates the folders and subfolders if they don't exist
        CreatePath Path
        
        If Not IsEmpty(CheckingCell.Value) Then
            WS.Hyperlinks.Add Anchor:=CheckingCell, Address:=Path, _
                              TextToDisplay:=CheckingCell.Value
        End If
    Next
    
    With Range("E9:E1200").Font
        .ColorIndex = x1Automatic
        .Underline = xlUnderlineStyleNone
        .Name = "Times New Roman"
        .Size = 18
    End With
End Sub

Sub CreatePath(Path As String)
    Path = Replace(Path, "/", "\")

    Dim c As Long
    For i = 0 To UBound(Split(Path, "\"))
        c = InStr(c   1, Path, "\")
        If c = 0 Then c = Len(Path)
        CreateIfNotExist Mid(Path, 1, c)
    Next
End Sub
Sub CreateIfNotExist(Path As String)
    On Error Resume Next
    VBA.FileSystem.MkDir (Path)
    On Error GoTo 0
End Sub