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]

You you please post your complete code?

 

[Malhotra Rahul]

Hi Fluff Please find here below the script:

Sub RunMacro1_Click()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = False
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.UsedRange.SpecialCells(xlVisible).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
        
        .Colors = ThisWorkbook.Colors
        .SaveAs (NewName & ".xls")
       End With
      ThisWorkbook.Close SaveChanges:=True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub

</space></space>

 

[Fluff]

You've lost a next

         .SaveAs (NewName & ".xls")
     [COLOR=#ff0000] Next i[/COLOR]
   End With

 

[Malhotra Rahul]

Thank you so much Fluff, its perfectly giving the output as expected. Thanks a ton.

 

[Fluff]

Glad to help & thanks for the feedback