VBA to Copy two worksheets to New Workbook with conditional formatting

[saraapple]

From searching on site I have found and adapted some code which works perfectly:

Sub RunMacro1_Click()
Dim NewName As String

Worksheets(Array("Delivery schedule Stoke", "Delivery schedule Meridian")).Copy
NewName = InputBox("Please Enter the name for the new workbook", "New Workbook Name")
With ActiveWorkbook
.SaveAs (NewName & ".xls")
.Close savechanges:=True
End With
ThisWorkbook.Close savechanges:=False

End Sub

HOWEVER...….is it possible to change this to copy over my conditional formatting?
I can copy and paste to a new sheet and achieve this by using:

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

Can this be incorporated to copy the formatting to the new workbook?

Thank you
Sara

 

[ZVI]

Hi,
To paste CFs just paste also formats - insert one more code line with Paste:=xlPasteFormats like this:

Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False

Regards

 

[saraapple]

Thank you for the reply but how do I add the code to the macro I already have?
My current macro does not paste it copies to a new worksheet - how do you put the paste command into the code?

 

[ZVI]

Could you please post your current code, as the code in the post#1 copies sheets including their CFs.

 

[JLGWhiz]

The Sheets.Copy method does not carry the attributes of the conditional formats with it. However, if you create a ne workbook whith the Workbooks.add method and then copy the UsedRange of the soruce sheet to Sheet1 of the new workbook, it will bring everything overr:

Workbooks.Add
SorceSheet.UsedRange.Copy ActiveWorkbook.Sheets(1).Range("A1")

 

[JLGWhiz]

Could you please post your current code, as the code in the post#1 copies sheets including their CFs.

@ZVI - Check the CF rules on the copied sheet and you will find them blank. It only copies any current results of the origingal CF, but not the rules.

 

[JLGWhiz]

See if this will do what you want:

Sub RunMacro1_Click()
Dim NewName As String, ary As Variant, i As Long
ary = Array("Delivery schedule Stoke", "Delivery schedule Meridian")
NewName = InputBox("Please Enter the name for the new workbook", "New Workbook Name")
Workbooks.Add
    For i = LBound(ary) To UBound(ary)
        Sheets(ary(i)).UsedRange.Copy ActiveWorkbook.Sheets(i + 1), Range("A1")
    Next
    With ActiveWorkbook
        .SaveAs (NewName & ".xls")
        .Close savechanges:=True
    End With
ThisWorkbook.Close savechanges:=False
End Sub

 

[saraapple]

Thank you so much for your advice. I have added the code but I get "Run-time error '9': Subscript out of range".
I have followed it through and a new work book is created with a blank "Sheet 1" but then the code stops at:
Sheets(ary(i)).UsedRange.Copy ActiveWorkbook.Sheets(i + 1), Range("A1")

I do not understand this line so am struggling to see the problem?

 

[ZVI]

@ZVI - Check the CF rules on the copied sheet and you will find them blank. It only copies any current results of the origingal CF, but not the rules.

You are correct, thank you! But I meant that code of RunMacro1_Click in the post #1 copies CFs as well, as it does not use Workbooks.Add

 

[ZVI]

Try this:

Sub RunMacro1_Click()

  Dim NewName As String
  Dim Sh As Worksheet, Shts As Variant

  Set Shts = ActiveWorkbook.Worksheets(Array("Delivery schedule Stoke", "Delivery schedule Meridian"))
  Shts.Copy
  
  NewName = InputBox("Please Enter the name for the new workbook", "New Workbook Name")
  With ActiveWorkbook
    .SaveAs NewName & ".xlsx", FileFormat:=xlOpenXMLWorkbook
    '.Close
  End With

  'ThisWorkbook.Close SaveChanges:=False

End Sub

After succesfull testing uncomment these lines: '.Close and 'ThisWorkbook.Close SaveChanges:=False