保存后 - 在新工作簿中创建 2 张无公式复制并另存为

如何解决保存后 - 在新工作簿中创建 2 张无公式复制并另存为

我有一个包含许多工作表的大型 Excel 文件 (ORIGINAL.xlsm)。当我保存 ORIGINAL.xlsm 时，我需要自动创建另一个文件 (COPY.xlsx)。 COPY.xlsx 文件应仅包含 2 张纸（EXP1 和 EXP2）。 但是 EXP1 和 EXP2 必须只包含没有公式的值，并且 ORIGINAL.xlsm 可能不受此操作的影响。 我正在尝试解决，但原始文件总是受到负面影响（公式已删除）。我想避免使用 ActiveWorkBook 调用，因为它经常与多个打开的 Excel 一起操作。

    Option Explicit
Private Sub Workbook_AfterSave(ByVal Success As Boolean)
Dim UserProfile As String
Dim Path As String
Dim NewBook2 As Workbook
UserProfile = VBA.Environ$("Userprofile")

Path = UserProfile & "\Dropbox\Program\COPY.xlsx"


Set NewBook2 = Workbooks.Add
NewBook2.SaveAs Filename:=Path

ThisWorkbook.Sheets("EXP1").Copy Before:=Workbooks("COPY.xlsx").Sheets(1)
ThisWorkbook.Sheets("EXP2").Copy Before:=Workbooks("COPY.xlsx").Sheets(2)

Workbooks("COPY.xlsx").Sheets("EXP2").Activate
Workbooks("COPY.xlsx").Sheets("EXP2").UsedRange.Select


Workbooks("COPY.xlsx").Sheets("EXP2").Copy Before:=Workbooks("COPY.xlsx").Sheets(2)

REM PROBLEM HERE
Workbooks("COPY.xlsx").UsedRange.Value = Workbooks("COPY.xlsx").UsedRange.Value

End Sub

解决方法

您既不需要带有 .Activate 的行也不需要带有 .Select 的行来使此代码工作。你可能会从阅读中受益 How to avoid using Select in Excel VBA。

请注意，您的 Workbooks("COPY.xlsx") 已设置为 NewBook2，因此最好使用该变量，以防名称 COPY.xlsx 发生变化，NewBook2 将始终有效。

Option Explicit

Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim UserProfile As String
    UserProfile = VBA.Environ$("Userprofile")

    Dim Path As String
    Path = UserProfile & "\Dropbox\Program\COPY.xlsx"
    
    Dim NewBook2 As Workbook
    Set NewBook2 = Workbooks.Add
    NewBook2.SaveAs Filename:=Path
    
    ThisWorkbook.Sheets("EXP1").Copy Before:=NewBook2.Sheets(1)
    ThisWorkbook.Sheets("EXP2").Copy Before:=NewBook2.Sheets(2)

    NewBook2.Sheets(2).UsedRange.Value = NewBook2.Sheets(2).UsedRange.Value

    'here you need to save and probably close your new workbook
    NewBook2.Close SaveChanges:=True 'or NewBook2.Save if you want to keep it open.
End Sub

您遇到的问题是工作簿没有像 UsedRange 这样的 Workbooks("COPY.xlsx").UsedRange，您需要指定像 NewBook2.Sheets(2).UsedRange 这样的工作表。

,

这对我有用...谢谢 我不太自信 Excel 中的相对链接作为 ActiveWorkbook 或 NewBook2.Sheets(2) 出于这个原因，打开的文件名在我的代码中。 事实证明，这最适用于更开放的 Excel（对我而言）。

        Option Explicit
    Private Sub Workbook_AfterSave(ByVal Success As Boolean)
    Dim UserProfile As String
    UserProfile = VBA.Environ$("Userprofile")
    
    Dim path As String
    path = UserProfile & "\Dropbox\Program\COPY.xlsx"
    
    Dim NewBook2 As Workbook
    Set NewBook2 = Workbooks.Add
    NewBook2.SaveAs Filename:=path
    
    ThisWorkbook.Sheets("EXP1").Copy Before:=Workbooks("COPY.xlsx").Sheets(1)
    ThisWorkbook.Sheets("EXP2").Copy Before:=Workbooks("COPY.xlsx").Sheets(2)
    
    Workbooks("COPY.xlsx").Sheets("EXP2").Activate
    Workbooks("COPY.xlsx").Sheets("EXP2").UsedRange.Select
    Workbooks("COPY.xlsx").Sheets("EXP2").UsedRange.Value = Workbooks("COPY.xlsx").Sheets("EXP2").UsedRange.Value
  
rem if file exists no alert display  
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Workbooks("COPY.xlsx").SaveAs Filename:=path
    Workbooks("COPY.xlsx").Close
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    End Sub