将一个工作簿复制到另一个工作簿时排除特定的单元格被复制

我正在使用的代码将表单作为数组并将它们复制为XlValues，但是很less包含要保留并粘贴为xlFormats的公式的单元格。 我怎么能做到这一点？

Sub CopyPasteSave() Dim NewName As String Dim nm As Name Dim ws As Worksheet Dim Path As String, rcell As Range Set rcell = Sheets("EPF Daily Report").Range("I5") Path = "D:\" If MsgBox("Copy specific sheets to a new workbook" & vbCr & _ "New sheets will be pasted as values, named ranges removed" _ , vbYesNo, "NewCopy") = vbNo Then Exit Sub With Application .ScreenUpdating = False ' Copy specific sheets ' *SET THE SHEET NAMES TO COPY BELOW* ' Array("Sheet1", "Sheet2")) ' Sheet names go inside quotes, seperated by commas On Error GoTo ErrCatcher Sheets(Array("InletManifold", "Separator", "Crude Strippers & Reboilers ", "Water Strippers & Reboilers ", "Crude Storage&Export", "GSU,FLARE & GEN", "EPF Utility", "EPF Daily Report", "Choke Size")).Copy On Error GoTo 0 ' Paste sheets as values ' Remove External Links, Hperlinks and hard-code formulas ' Make sure A1 is selected on all sheets For Each ws In ActiveWorkbook.Worksheets ws.Cells.Copy ws.[A1].PasteSpecial Paste:=xlValues Application.DisplayAlerts = False ws.Cells.Hyperlinks.Delete Application.CutCopyMode = False Cells(1, 1).Select ws.Activate Next ws Cells(1, 1).Select ' Remove named ranges For Each nm In ActiveWorkbook.Names nm.Delete Next nm ' Input box to name new file 'NewName = InputBox("Please Specify the name of your new workbook", "New Copy") ' Save it with the NewName and in the same directory as original ActiveWorkbook.SaveAs Filename:=Path & " " & "EPF Daily Report" & " " & rcell.Value & ".xls" ActiveWorkbook.Close SaveChanges:=True .ScreenUpdating = False End With Exit Sub ErrCatcher: MsgBox "specified sheets do not exist within this work book" End Sub 

Answer 1

我将下面的工作表复制为值后，将复制从原始工作簿中指定的单元格，使用PasteSpecial使其公式保持不变。 几个注意事项：

• 添加了一个包含地址的数组CellsToCopy ，例如，您想用公式复制的B11和B12。 根据需要进行修改。
• 添加了wbSource和wbTarget工作簿variables，以在PasteSpecial引用
• 清理你的代码，重新打开DisplayAlerts ，并添加到error handling
• 摆脱您的Select语句，并replaceApplication.GoTo

此外，请注意，您不必做任何特殊的事情来保留格式，因为作为值的副本不会改变它们。

 Sub CopyPasteSave() Dim wbSource As Excel.Workbook Dim wbTarget As Excel.Workbook Dim nm As Name Dim ws As Worksheet Dim CellsToCopy() As String Dim i As Long Dim Path As String Dim rcell As Range If MsgBox("Copy specific sheets to a new workbook" & vbCr & _ "New sheets will be pasted as values, named ranges removed" _ , vbYesNo, "NewCopy") = vbNo Then Exit Sub End If Set wbSource = ActiveWorkbook Set rcell = Sheets("EPF Daily Report").Range("I5") Path = "D:\" 'Enter cells to copy with formulas CellsToCopy = Split(("B11,B12"), ",") Application.ScreenUpdating = False ' Copy specific sheets ' *SET THE SHEET NAMES TO COPY BELOW* ' Sheet names go inside quotes, separated by commas On Error GoTo ErrCatcher wbSource.Sheets(Array("InletManifold", "Separator", "Crude Strippers & Reboilers ", "Water Strippers & Reboilers ", "Crude Storage&Export", "GSU,FLARE & GEN", "EPF Utility", "EPF Daily Report", "Choke Size")).Copy On Error GoTo 0 ' Paste sheets as values ' Remove External Links, Hyperlinks and hard-code formulas ' Make sure A1 is selected on all sheets Set wbTarget = ActiveWorkbook For Each ws In wbTarget.Worksheets With ws .Cells.Copy .[A1].PasteSpecial Paste:=xlValues For i = LBound(CellsToCopy) To UBound(CellsToCopy) wbSource.Worksheets(ws.Name).Range(CellsToCopy(i)).Copy ws.Range(CellsToCopy(i)).PasteSpecial xlPasteFormulas Next i Application.CutCopyMode = False Application.DisplayAlerts = False .Cells.Hyperlinks.Delete Application.DisplayAlerts = True Application.Goto .Range("A1") End With Next ws With wbTarget ' Remove named ranges For Each nm In .Names nm.Delete Next nm ' Input box to name new file 'NewName = InputBox("Please Specify the name of your new workbook", "New Copy") ' Save it with the NewName and in the same directory as original .SaveAs Filename:=Path & " " & "EPF Daily Report" & " " & rcell.Value & ".xls" .Close SaveChanges:=True End With Exit_Point: Application.ScreenUpdating = False Application.DisplayAlerts = True Exit Sub ErrCatcher: MsgBox "specified sheets do not exist within this work book" Resume Exit_Point End Sub