1

我正在使用的代码将工作表作为数组并将它们复制为 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
4

1 回答 1

2

在将工作表复制为值之后，我在下面所做的是复制您从原始工作簿中指定的单元格，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
于 2012-12-29T16:54:07.390 回答