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

Question

I need a code for the below.

First check 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.

The below code creates the same except subfolder.

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

Answer 1

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