excel - VBA SaveAs 到 .xlsm 不包含任何宏模块

Question

我有一个基本上复制当前文件的功能，并将其保存到用户的“下载”文件夹中。

但是，虽然SaveAs有效，但输出不包含任何模块。相反，它们都链接到导出文件。

Sub PushToProduction()
    Application.ScreenUpdating = False
 
    ' save a copy of current file to the Downloads folder
    outputPath = Environ$("USERPROFILE") & "\Downloads\"
    d = Format(Date, "yyyymmdd")
    fileName = outputPath & "REDACTED " & d & " v1.00.xlsm"
    
   ' prepare to save a copy of the file without the last tab
    sheetCount = Application.Sheets.Count - 1
    Dim tabs() As String
    ReDim tabs(1 To sheetCount)
    For i = 1 To sheetCount
        tabs(i) = Worksheets(i).Name
    Next
    
    Worksheets(tabs).Copy
    
   
    ActiveWorkbook.SaveAs fileName, XlFileFormat.xlOpenXMLWorkbookMacroEnabled
    ActiveWorkbook.Close False
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
    MsgBox ("Success!")
End Sub

输出甚至没有“模块”文件夹。

有没有办法解决这个问题？

标签： excelvba

Answer 1

创建工作簿副本并修改它

Option Explicit

Sub PushToProduction()
 
    Dim dFolderPath As String
    dFolderPath = Environ$("USERPROFILE") & "\Downloads\"
    Dim d As String: d = Format(Date, "yyyymmdd")
    Dim dFilePath As String
    dFilePath = dFolderPath & "REDACTED " & d & " v1.00.xlsm"
    
    Application.ScreenUpdating = False
    
    ' Create a reference to the Source Workbook ('swb').
    Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
    ' Save a copy of the Source Workbook.
    If StrComp(dFilePath, swb.FullName, vbTextCompare) = 0 Then
        MsgBox "You are trying save a copy of the file to the same location.", _
            vbCritical, "Push to Production"
        Exit Sub
    End If
    swb.SaveCopyAs dFilePath
    
    ' Open the copy, the Destination Workbook ('dwb'), remove its last sheet
    ' and close saving the changes.
    Dim dwb As Workbook: Set dwb = Workbooks.Open(dFilePath)
    Application.DisplayAlerts = False
    dwb.Sheets(dwb.Sheets.Count).Delete
    Application.DisplayAlerts = True
    dwb.Close SaveChanges:=True
    
    Application.ScreenUpdating = True
    
    ' Inform.
    MsgBox "Success!", vbInformation, "Push to Production"
    
    ' Explore Destination Folder.
    'swb.FollowHyperlink dFolderPath
    
End Sub