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

Question

我正在使用的代码将表单作为数组并将它们复制为XlValues，但很少包含要保留并粘贴为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工作簿变量，是指在PasteSpecial
• 荡涤你的代码，重新开启DisplayAlerts，并添加 错误处理
• 摆脱了您的Select语句，取而代之的是 Application.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