Save excel Workbook in a new created folder with the Same names

Question

I found this code and it should create a new folder and should save the file in it.
Problem here the code doesn't work...

The code I found should create a folder in the code written path but i want that it creates the folder and the new sheets in the same path as the workbook now is. i don't know how I can bin this in "thisWb.Path"

Original code i found

Sub Macro1()
Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Range("A1").Value ' New directory name

strFilename = Range("A2").Value 'New file name
strDefpath = "C:\My Documents\" 'Default path name
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & strDirname
strPathname = strDefpath & strDirname & "\" & strFilename 'create total string

ActiveWorkbook.SaveAs FileName:=strPathname, _
FileFormat:=xlNormal, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

"The idea is That it wokrs like a templete ypu fill your stuff in the form and press the button and it saves the file(only the one sheet in .xls) in a new Folder(both same names, like 1102) for you"

---

But i still have no clue how i only can save one sheet so the file with the macro in works like a template and can save the forms to the freshly created folders. like a copy. so that i can continue working in my file with the macro..

Code that works! thanks to @Balinti

Sub Macro1()
Dim strFilename, strDirname, strPathname, strDefpath As String
On Error Resume Next ' If directory exist goto next line
strDirname = Range("D81").Value ' New directory name

strFilename = Range("D8").Value 'New file name
strDefpath = Application.ActiveWorkbook.Path 'Default path name
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string

ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

Answer 1

There are 3 problems with code you supplied.

First is On error resume next which do not make all of your commands go through if there is some error. The 2nd is that the folder you supplied is probably for old versions of windows where you had the "my documents" folder on drive C directly. Now it is usually going through "\user" etc. so you might have access denied problems or it opens new folder on root c which is not your real document folder.

To get the current saving directory use:

 strDefpath = Application.ActiveWorkbook.Path

And the 3rd is that you try to save a macro enabled file as a regular excel file. again, I believe this concern to older version of Excel where there where no differences in the extension between regular excel and macro enabled. (they were both xls and no we have xlsx and xlsm)

To save your file as a macro enable you need a line like :

    ActiveWorkbook.SaveAs Filename:=strDefpath & ".xlsm",
 FileFormat:=xlOpenXMLWorkbookMacroEnabled

Or all together:

Sub Macro1()
Dim strFilename, strDirname, strPathname, strDefpath As String
 On Error Resume Next ' If directory exist goto next line
strDirname = Range("D81").Value ' New directory name

strFilename = Range("D8").Value 'New file name
strDefpath = Application.ActiveWorkbook.Path 'Default path name
If IsEmpty(strDirname) Then Exit Sub
If IsEmpty(strFilename) Then Exit Sub

MkDir strDefpath & "\" & strDirname
strPathname = strDefpath & "\" & strDirname & "\" & strFilename 'create total string

ActiveWorkbook.SaveAs Filename:=strPathname & ".xlsm", _
FileFormat:=xlOpenXMLWorkbookMacroEnabled, Password:="", WriteResPassword:="", _
ReadOnlyRecommended:=False, CreateBackup:=False
End Sub

Answer 2

Here is an example of creating a new subfolder in an existing folder and saving a macro-enabled version of the Active book in it:

Sub swi()
   Dim NewPath As String
   NewPath = "C:\TestFolder\Swi"
   MkDir NewPath
   ActiveWorkbook.SaveAs Filename:=NewPath & "\" & "whatever.xlsm", FileFormat:=xlOpenXMLWorkbookMacroEnabled
End Sub