CODEWITHSUNDEEP
excelexcel-2010vba
Mohammed Almudhafar
Mohammed Almudhafar

Reputation: 67

Excluding specific cells from being copied when copy one Workbook to another Workbook

The code I am using takes sheets as array and copies them as XlValues, but there are few cells containing formulas which I want to keep and paste as xlFormats. How can i achieve that?

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

Upvotes: 1

Views: 1700

Answers (1)

Doug Glancy
Doug Glancy

Reputation: 27478

What I've done below, after the sheets are copied as values, is to copy cells that you specify from the original workbook, using PasteSpecial to keep their formulas intact. A couple of notes:

  • Added an array, CellsToCopy, that contains the addresses, e.g., B11 and B12 that you want to copy with formulas. Mdoify this as needed.
  • Added wbSource and wbTarget workbook variables, to refer to in the PasteSpecial
  • Cleaned up your code, turning DisplayAlerts back on, and adding to the error handling
  • Got rid of your Select statement and replaced with Application.GoTo

Also, note that you don't have to do anything special to keep the formats, as the copy as values will not have changed them.

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

Upvotes: 2

Related Questions