Create and open folder modify path-CodePudding

I use the code below to create and open a folder from excel when I press a button but I want the created folder to be in the same location like the excel workbook. Can you please help me modif the code? Thank you!

Sub btn1_click()
Dim dir As String
Dim fso As Object
Dim path As String
path = Application.ActiveWorkbook.path
dir = ActiveCell.value
Set fso = CreateObject("scripting.filesystemobject")
If Not fso.folderexists(dir) Then
    fso.createfolder (dir)
End If
    Call Shell("explorer.exe" & " " & dir, vbNormalFocus)
   
End Sub

CodePudding user response：

Create and Explore a Subfolder Using the Active Cell's Value

The code is written for any active cell so be a little careful how you use it to not end up with folders in the wrong places.
If you run it by using a button, you are ensuring that it will use the right cell since the active sheet is the one containing the button and containing the active cell.

Sub CreateActiveCellSubFolder()
    
    Const ExploreIfSubFolderExists As Boolean = True
    
    Dim ash As Object: Set ash = ActiveSheet ' it could be a chart
    
    If ash Is Nothing Then ' no active sheet
        MsgBox "No visible workbooks open.", _
            vbCritical
        Exit Sub
    End If
    
    If ash.Type <> xlWorksheet Then
        MsgBox "The active sheet '" & ash.Name & "' is not a worksheet.", _
            vbCritical
        Exit Sub
    End If
    
    Dim wb As Workbook: Set wb = ash.Parent
    
    If Len(wb.Path) = 0 Then
        MsgBox "The workbook '" & wb.Name & "' containing the active sheet '" _
            & ash.Name & "' has not been saved yet.", _
            vbCritical
        Exit Sub
    End If
    
    ' If the active sheet is a worksheet, it has an active cell at any time,
    ' no matter what is selected.
    Dim aCell As Range: Set aCell = ActiveCell
    
    Dim SubFolderName As String: SubFolderName = CStr(ActiveCell.Value)
    
    If Len(SubFolderName) = 0 Then
        MsgBox "The cell '" & aCell.Address(0, 0) & "' is blank.", _
            vbCritical
        Exit Sub
    End If
    
    Dim SubFolderPath As String
    SubFolderPath = wb.Path & Application.PathSeparator & SubFolderName
    
    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    If fso.FolderExists(SubFolderPath) Then
        MsgBox "The folder '" & SubFolderName & "' already exists.", _
            vbInformation
        If Not ExploreIfSubFolderExists Then Exit Sub
    Else
        Dim ErrNum As Long
        On Error Resume Next
            fso.CreateFolder SubFolderPath
            ErrNum = Err.Number
'            If ErrNum > 0 Then
'                Debug.Print "Run-time error '" & Err.Number & "': " _
'                    & Err.Description
'            End If
        On Error GoTo 0
        If ErrNum = 0 Then
            MsgBox "Created the folder '" & SubFolderName & "'.", _
                vbInformation
        Else
            MsgBox "Could not create the folder '" & SubFolderName & "'.", _
                vbCritical
            Exit Sub
        End If
    End If
    
    wb.FollowHyperlink SubFolderPath
   
End Sub