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 你想用公式复制。根据需要对此进行Mdoify。
添加了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

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

1 个答案: