VBA to Copy two worksheets to New Workbook

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
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.

Code:
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>
 
Last edited:

Some videos you may like

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
Hi, I do have issue only for the point 1 for changing color while copying to the new worksheets but not the second one.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
38,568
Office Version
365
Platform
Windows
It sounds like you are not using the default colour scheme.
Try recording a macro of you setting the colour scheme you want & then you can add that to your macro
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,493
Office Version
365, 2010
Platform
Windows
Does this get you any closer to what you want to do. This will keep your formatting and formulas from the copied sheets.

Code:
Sub RunMacro1_Click()




    Dim NewName As String
    
    Worksheets(Array("MySheet1", "MySheet2")).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
I hope this helps.
 

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
I could have done that but the problem is both worksheets color ranges a different for MySheet1 the below script i am using for alternate row color:

Code:
Private Sub worksheet_SelectionChange(ByVal target As Range)

Dim i, c As Range, FRows, rng As Range
    Set rng = Cells(12, 2).Resize(Cells(Rows.Count, 2).End(xlUp).Row - 11)
    
    With CreateObject("scripting.dictionary")
        For Each c In rng.Cells
            If c.EntireRow.Hidden = False Then
                i = i + 1
                .Item(i) = i Mod 2
                Select Case c.Row
                    Case 11, 62, 63, 113, 114 To 117, 164 To 165, 195 To 196, 320, 321, 357, 358, 370 To 381
                    Case Else
                    If .Item(i) = 1 And InStr(c.Value, "Blank") = 0 Then
                        c.Resize(, 18).Interior.ColorIndex = 22 'SkyBlue
                        Else
                        c.Resize(, 18).Interior.ColorIndex = -4142 'White
                    End If
                End Select
            End If
        Next c
    End With
End If
End Sub
and for MySheet2 i am using the below script for changing the alternate row color:

Code:
Private Sub worksheet_SelectionChange(ByVal target As Range)

Dim i, c As Range, FRows, rng As Range
    Set rng = Cells(12, 2).Resize(Cells(Rows.Count, 2).End(xlUp).Row - 11)
    
    With CreateObject("scripting.dictionary")
        For Each c In rng.Cells
            If c.EntireRow.Hidden = False Then
                i = i + 1
                .Item(i) = i Mod 2
                Select Case c.Row
                    Case 11, 62, 63, 113 To 117, 118, 119, 166 To 167, 197, 198 To 200, 324 To 329, 365, 366, 378 To 384
                    Case Else
                    If .Item(i) = 1 And InStr(c.Value, "Blank") = 0 Then
                        c.Resize(, 14).Interior.ColorIndex = 22 'SkyBlue
                        Else
                        c.Resize(, 14).Interior.ColorIndex = -4142 'White
                    End If
                End Select
            End If
        Next c
    End With
End If
End Sub
Now the problem for me is how to incorporate these two different colors with in the single above script. Because both worksheets rows and columns range are different.

and i while copying i also want to skip the hidden rows and columns to copy.
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,493
Office Version
365, 2010
Platform
Windows
Hi,

Did you see/try my Post #4 .
 

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
Does this get you any closer to what you want to do. This will keep your formatting and formulas from the copied sheets.

Code:
Sub RunMacro1_Click()




    Dim NewName As String
    
    Worksheets(Array("MySheet1", "MySheet2")).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
I hope this helps.
The provided script is copying bar graphs and formulae as well which is throwing error in the new worksheet as #Ref but script which i am currently using copies only the print range not the shapes.
 

igold

Well-known Member
Joined
Jul 8, 2014
Messages
2,493
Office Version
365, 2010
Platform
Windows
Ah, I was trying to overcome the obstacles you stated as 1) and 2) in your OP.
 

Fluff

MrExcel MVP, Moderator
Joined
Jun 12, 2014
Messages
38,568
Office Version
365
Platform
Windows
As ColorIndex 22 is a reddish colour not SkyBlue, you must have some sort of custom colour pallet, which you will need to copy over to the new workbook.
 

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
Hi Fluff, but it's giving me the sky blue colour. Which is visible in green red and black font.
 
Last edited:

Watch MrExcel Video

Forum statistics

Threads
1,095,389
Messages
5,444,191
Members
405,273
Latest member
cswshaun

This Week's Hot Topics

Top