excelvbasave-as

Application.FileDialog(msoFileDialogFolderPicker) is not working properly, does not give the correct path to the selected folder


I am trying to write a program that allows you to save a sheet in a workbook to a folder of your choosing.

The issue is that when you run the macro and select the folder you want to save the sheet too, if you click OK it saves outside of the selected folder and when you press cancel it saves inside the selected folder.

The idea that im trying to go for is when I press OK it saves inside the selected folder and when I press cancel it cancels.

Any help is appreciated.

Sub CopySheetAsNewWorkbookWithPickingFileLocation()
Dim theNewWorkbook As Workbook
Dim currentWorkbook As Workbook
Dim newFileName As String
Dim fldr As FileDialog
Dim sItem As String
Dim GetFolder As String

'Picking a folder to save to
Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
With fldr
    .Title = "Select a Folder"
    .AllowMultiSelect = False
    If .Show <> -1 Then GoTo NextCode
    sItem = .SelectedItems(1)
End With

NextCode: sItem = GetFolder Set fldr = Nothing

'Make new file name = sheet name
newFileName = ActiveSheet.Name

'currentWorkbook is the source workbook, create a new workbook referencing to it with theNewWorkbook
Set currentWorkbook = ActiveWorkbook
Set theNewWorkbook = Workbooks.Add

'do the copy (it's better to check if there is already a 'Worksheet 1' in the new workbook. It it exists delete it or rename it
currentWorkbook.ActiveSheet.Copy before:=theNewWorkbook.Sheets(1)

'Remove default sheets in order to have only the copied sheet inside the new workbook
Application.DisplayAlerts = False
Dim i As Integer
For i = theNewWorkbook.Sheets.Count To 2 Step -1
    theNewWorkbook.Sheets(i).Delete
Next i
Application.DisplayAlerts = True

'Save File
saveLocation = GetFolder
theNewWorkbook.SaveAs Filename:=newFileName & ".xlsx", FileFormat:=61
theNewWorkbook.Close

End Sub

Solution

  • Edited and marked changes in your code:

    Sub CopySheetAsNewWorkbookWithPickingFileLocation()
    Dim theNewWorkbook As Workbook
    Dim currentWorkbook As Workbook
    Dim newFileName As String
    Dim fldr As FileDialog
    Dim sItem As String
    Dim GetFolder As String
    
    'Picking a folder to save to
    Set fldr = Application.FileDialog(msoFileDialogFolderPicker)
    With fldr
        .Title = "Select a Folder"
        .AllowMultiSelect = False
        If .Show <> -1 Then Exit Sub 'GoTo NextCode  if not selected quit the code.
        sItem = .SelectedItems(1)
    End With
    
    'NextCode: sItem = GetFolder Set fldr = Nothing not necessary to remove variable, and define another.
    
    'Make new file name = sheet name
    newFileName = ActiveSheet.Name
    
    'currentWorkbook is the source workbook, create a new workbook referencing to it with theNewWorkbook
    Set currentWorkbook = ActiveWorkbook
    Set theNewWorkbook = Workbooks.Add
    
    'do the copy (it's better to check if there is already a 'Worksheet 1' in the new workbook. It it exists delete it or rename it
    currentWorkbook.ActiveSheet.Copy before:=theNewWorkbook.Sheets(1)
    
    'Remove default sheets in order to have only the copied sheet inside the new workbook
    Application.DisplayAlerts = False
    Dim i As Integer
    For i = theNewWorkbook.Sheets.Count To 2 Step -1
        theNewWorkbook.Sheets(i).Delete
    Next i
    Application.DisplayAlerts = True
    
    'Save File
    'saveLocation = GetFolder  not necessary a new variable
    'theNewWorkbook.SaveAs Filename:=GetFolder & "\" & newFileName & ".xlsx", FileFormat:=61 'define the full path of the target file.
    theNewWorkbook.SaveAs Filename:=sItem & "\" & newFileName & ".xlsx", FileFormat:=61 'define the full path of the target file.
    theNewWorkbook.Close
    
    End Sub