vba 将excel工作簿保存在一个新创建的同名文件夹中

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

提问by Swi

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"

我找到的代码应该在代码编写的路径中创建一个文件夹，但我希望它在与工作簿相同的路径中创建文件夹和新工作表。我不知道如何将其放入“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"

“这个想法是它像一个模板一样工作，在表格中填写你的东西并按下按钮，它将文件（只有 .xls 中的一张）保存在一个新文件夹中（两个名称相同，如 1102）为你“

---

---

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

有效的代码！感谢@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

回答by Balinti

There are 3 problems with code you supplied.

您提供的代码存在 3 个问题。

First is On error resume nextwhich 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.

首先是On error resume next如果出现错误，则不会使您的所有命令都通过。第二个是您提供的文件夹可能适用于旧版本的 Windows，您直接在驱动器 C 上拥有“我的文档”文件夹。现在它通常通过“\user”等，因此您可能遇到访问被拒绝的问题，或者它会在根 c 上打开新文件夹，这不是您真正的文档文件夹。

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)

第三个是您尝试将启用宏的文件另存为常规 Excel 文件。再次，我相信对旧版本的 Excel 的关注，其中常规 excel 和启用宏之间的扩展名没有差异。（它们都是 xls，不，我们有 xlsx 和 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

回答by Gary's Student

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:

以下是在现有文件夹中创建新子文件夹并在其中保存启用宏的 Active book 版本的示例：

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