Create and open folder modify path - excel

Question

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

Answer 1

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