將一個工作簿複製到另一個工作簿時排除特定單元格

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