VBA to Copy two worksheets to New Workbook

[Malhotra Rahul]

Hi, I am using the below script for copy two worksheet to a new workbook but i do have two issue with this:

With the available script:

1) As my original worksheet alternate rows are filled with specific color, which is getting change after copying the data to new worksheet.

2) When the pop up ask for giving the new name to the workbook then also it takes automatically a new name like Book8 and not the given name.

Option Explicit

Sub RunMacro1_Click()


    
        Dim NewName As String, s As String, wb As Workbook, ws As Worksheet, i As Integer, x
    
    s = "MySheet1 & MySheet2"  '//EDIT OR ADD SHEETS TO BE COPIED HERE (INCLUDE '<space>&<space>' BETWEEN NAMES)
    x = Split(s, " & ")
    
    If MsgBox("Sheets:" & vbCr & vbCr & s & vbCr & vbCr & "will be copied to a new workbook" & vbCr & vbCr & _
    "The sheets will be values only (named ranges, formulas and links removed)" & vbCr & vbCr & _
    "Do you want to continue?", vbYesNo, "Create New Workbook") = vbNo Then Exit Sub
    
    NewName = InputBox("Please Enter the name for the new workbook", "New Workbook Name")


    Application.ScreenUpdating = False
    Workbooks.Add
    Set wb = ActiveWorkbook
    With wb
        For i = 0 To UBound(x)
            Set ws = ThisWorkbook.Sheets(x(i))
            ws.Cells.Copy
            .Sheets.Add after:=Sheets(Sheets.Count): .ActiveSheet.name = x(i)
            With .Sheets(x(i))
                .[a1].PasteSpecial Paste:=xlValues
                .Cells.PasteSpecial Paste:=xlFormats
                .Cells.Hyperlinks.Delete
                Application.Goto .[a1]
            End With
        Next
        Application.DisplayAlerts = False
        For i = 1 To 1
            .Sheets("Sheet" & i).Delete
        Next
        Application.DisplayAlerts = True
        .SaveAs (NewName & ".xls")
    End With
    ThisWorkbook.Close SaveChanges:=False
    Application.ScreenUpdating = True


    
End Sub

Any help would be highly appreciated. Thank you in advance.</space></space>

 

[Fluff]

Which is why I said that you must have a custom colour palette.
You can see the original colours here http://dmcritchie.mvps.org/excel/colors.htm

 

[Malhotra Rahul]

Hi Fluff, is it possible to copy with the present script and get the alternate row colours in SkyBlue to new workbook.

 

[Fluff]

Try adding this line of code

      Application.DisplayAlerts = True
     [COLOR=#ff0000] .Colors = ThisWorkbook.Colors[/COLOR]
      .SaveAs (NewName & ".xls")

 

[Malhotra Rahul]

Hi Fluff, the color copy have been resolved. Thank you so much. Dear Fluff is it possible to exclude hidden rows while copying.

 

[Fluff]

Try

Set Ws = ThisWorkbook.Sheets(x(i))
[COLOR=#ff0000]Ws.UsedRange.SpecialCells(xlVisible).Copy[/COLOR]
.Sheets.Add after:=Sheets(Sheets.Count): .ActiveSheet.name = x(i)

 

[Malhotra Rahul]

Try

Set Ws = ThisWorkbook.Sheets(x(i))
[COLOR=#ff0000]Ws.UsedRange.SpecialCells(xlVisible).Copy[/COLOR]
.Sheets.Add after:=Sheets(Sheets.Count): .ActiveSheet.name = x(i)

Hi Fluff, The script is getting debug at "Ws.UsedRange.SpecialCells(xlVisible).Copy". I have tried changing to "Ws.UsedRange.SpecialCells(xlCellTypeVisible).Copy" but then also it is getting debug.

 

[Fluff]

Do you have any sheets that can be empty?

 

[Malhotra Rahul]

As of now there is no empty worksheet available in my workbook but Yes i can create a sheet as empty.

 

[Fluff]

You do not need to create any new sheets.
When you get the error, what is the error message?
Also when you get the error, check which sheet Ws is refreing to & look to see if there are any visible cells within the usedrange.

 

[Malhotra Rahul]

Hi Fluff, I feel the debug part at "Ws.UsedRange.SpecialCells(xlVisible).Copy" have been resolved due to small changes in script but now it is getting debug at End With:

For i = 1 To 3
        .Sheets("Sheet" & i).Delete
        
        .Colors = ThisWorkbook.Colors
        .SaveAs (NewName & ".xls")
[COLOR=#ff0000]       End With[/COLOR]
      ThisWorkbook.Close SaveChanges:=True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

i have changed from "i = 1 to 1" to "i = 1 to 3"