Macro to Create Folder\Sub Folder\SubFolder\

Try this:

Private Sub CommandButton1_Click()
    Dim sDir As String
    
    sDir = Range("B3").Text
    
    If Len(Dir(sDir, vbDirectory)) Then
        MsgBox ("Directory already exists")
    Else
        MsgBox IIf(MakeDir(sDir), "Directory created", "Failed")
    End If
End Sub

Function MakeDir(ByVal sDir As String) As Boolean
    ' shg 2008
    ' Returns True if the directory sDir exists or is successfully created

    Static sPS  As String
    Dim astr()  As String
    Dim iLvl    As Long

    If Len(Dir(sDir, vbDirectory)) = 0 Then
        If Len(sPS) = 0 Then sPS = Application.PathSeparator

        If Right(sDir, 1) = sPS Then sDir = Left(sDir, Len(sDir) - 1)
        astr = Split(sDir, sPS)

        ' MkDir will fail if sDir contains characters 0-31
        ' or any of the characters ' < > : " / \ | ? *
        ' or if the drive does not exist
        
        sDir = ""
        On Error Resume Next
        For iLvl = 0 To UBound(astr)
            sDir = sDir & astr(iLvl) & sPS
            If Len(Dir(sDir, vbDirectory)) = 0 Then MkDir sDir
            If Err.Number <> 0 Then
                Err.Clear
                Exit Function   '---------------------------------------------->
            End If
        Next iLvl
    End If
    
    MakeDir = True
End Function

Thank you very much works a treat.

Many Thanks