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
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