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
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
The technical post webpages of this site follow the CC BY-SA 4.0 protocol. If you need to reprint, please indicate the site URL or the original address.Any question please contact:yoyou2525@163.com.