将Excel文件保存到目录中新创建的上一级文件夹中

Question

我想将我的文件保存在目录中上一级创建的文件夹中。

Set apfwb = Workbooks.Open(PathName & "\Resources\template V0.2.xlsm")
Dim apffr As Worksheet
Dim myFileName As String
Dim Path As String, FinalPath As String
Dim fso As Object
Dim fldrname As String, fldrpath As String

Path = Application.ActiveWorkbook.Path
FinalPath = Left(ActiveWorkbook.Path, InStrRev(ActiveWorkbook.Path, "\"))
myFileName = "Pack v0.2.xlsm"

Set fso = CreateObject("scripting.filesystemobject")
fldrname = "APF-MDU"
fldrpath = FinalPath & fldrname
FinalFile = fldrpath & myFileName
If Not fso.FolderExists(fldrpath) Then
    fso.createfolder (fldrpath)
End If

If FileLen(fldrpath & myFileName) > 0 Then
    MsgBox ("File arleady exists!")
    Exit Sub
Else
    Application.ActiveWorkbook.SaveAs fileName:=fldrpath & myFileName, 
    FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End If

文件保存在新创建的文件夹旁边。

如何将其保存在新创建的文件夹中？

Answer 1

从模板创建工作簿

• 未测试！

快速修复

'Dim apfwb As Workbook ' declared previously???
'Dim PathName As String ' declared and populated previously???

Dim apffr As Worksheet ' ???
Dim fso As Object
Dim fldrname As String, fldrpath As String
Dim myFileName As String, FinalPath As String

fldrname = "APF-MDU"
myFileName = "Pack v0.2.xlsm"

Set fso = CreateObject("Scripting.FileSystemObject")

fldrpath = PathName & "\" & fldrname & "\"
If Not fso.FolderExists(fldrpath) Then fso.CreateFolder fldrpath
FinalPath = fldrpath & myFileName

If fso.FileExists(FinalPath) Then
    MsgBox ("File arleady exists!")
    Exit Sub
Else
    Set apfwb = Workbooks.Open(PathName & "\Resources\template V0.2.xlsm")
    apfwb.SaveAs Filename:=FinalPath, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
End If

改进（独立）

Sub CreateFromTemplate()
   
    Const ROOT_PATH As String = "C:\Test"
    Const TEMPLATE_SUB_FILE_PATH As String = "Resources\Template V0.2.xlsm"
    Const NEW_FOLDER_NAME As String = "APF-MDU"
    Const NEW_FILE_NAME As String = "Pack v0.2.xlsm"

    Dim fso As Object: Set fso = CreateObject("Scripting.FileSystemObject")
    
    Dim nFolderPath As String:
    nFolderPath = fso.BuildPath(ROOT_PATH, NEW_FOLDER_NAME)
    
    If Not fso.FolderExists(nFolderPath) Then fso.CreateFolder nFolderPath
    
    Dim nFilePath As String:
    nFilePath = fso.BuildPath(nFolderPath, NEW_FILE_NAME)
        
    If fso.FileExists(nFilePath) Then
        MsgBox "The file """ & nFilePath & """ already exists!", vbExclamation
        Exit Sub
    End If

    Dim tFilePath As String:
    tFilePath = fso.BuildPath(ROOT_PATH, TEMPLATE_SUB_FILE_PATH)
    
    Dim wb As Workbook: Set wb = Workbooks.Open(tFilePath)
    
    wb.SaveAs Filename:=nFilePath, _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
    
    'wb.Close SaveChanges:=False ' just got saved
    
End Sub

Answer 2

例如（利用更多的 fso 方法）：

    Const FLDR_NM As String = "APF-MDU"
    Dim wb As Workbook, nfPath As String, nf As Object
    Dim fso As Object, pf As Object 
    
    Set fso = CreateObject("scripting.filesystemobject")
    
    Set wb = ThisWorkbook   'for example
    
    Set pf = fso.GetFolder(wb.Path).ParentFolder 'one level up
    
    nfPath = fso.BuildPath(pf.Path, FLDR_NM)
    If Not fso.FolderExists(nfPath) Then fso.CreateFolder nfPath
    
    wb.SaveAs FileName:=fso.BuildPath(nfPath, wb.Name), _
        FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False

Answer 3

您没有提到在发表评论之前发生的错误，因此我对您的代码进行了测试，在更改了一些内容后，它起作用了。

更改量最少的完整代码：

Sub test()
    Dim apfwb As Workbook, PathName As String 'added for testing
    PathName = "C:"                           'added 
    Set apfwb = Workbooks.Open(PathName & "\Resources\template V0.2.xlsm")
    Dim apffr As Worksheet
    Dim myFileName As String, FinalFile As String 'Added FinalFile to declaration
    Dim Path As String, FinalPath As String
    Dim fso As Object
    Dim fldrname As String, fldrpath As String
    
    Path = ActiveWorkbook.Path
    FinalPath = Left(Path, InStrRev(Path, "\")) 'Use the variable
    myFileName = "Pack v0.2.xlsm"
    
    Set fso = CreateObject("scripting.filesystemobject")
    fldrname = "APF-MDU"
    fldrpath = FinalPath & fldrname
    FinalFile = fldrpath & "\" & myFileName 'Don't forget the & "\"
    If Not fso.FolderExists(fldrpath) Then
        fso.CreateFolder (fldrpath)
    End If
    
    If Len(Dir(FinalFile)) > 0 Then 'use Dir instead with the variable you just filled
        MsgBox ("File arleady exists!")
        Exit Sub
    Else
        apfwb.SaveAs fileName:=FinalFile, _
            FileFormat:=xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False
        'Use the variable
    End If
End Sub

• 这里的要点是，使用您创建的变量，不要做两倍的工作而没有回报。

• Dir

  更容易检查文件是否存在，如果不存在，我在您的行中遇到错误

  If FileLen(fldrpath & myFileName) > 0

  。
• 缩进代码以提高可读性:)

如果没有保存在正确的路径中，请告诉我。