Add copy charts and shapes with the present script for copy tabs of workbook to new workbook

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
Hi I am using the below script for copying specific worksheets from a workbook. I want to add for copy multiple Charts and Shapes as picture. Charts as Chart No. 71, 24 & 35 and Shape as Rectangle 53, 54 & 54.

Code:
Option ExplicitSub 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 = "Report & Product Analysis & Customer Analysis"  '//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))
                .Cells.SpecialCells (xlCellTypeVisible)
                .[A1].PasteSpecial Paste:=xlValues
                .Cells.PasteSpecial Paste:=xlFormats
                .Cells.Hyperlinks.Delete
                
                Application.Goto .[A1]
            End With
        Next
        Worksheets("Variance").Visible = True
        Worksheets("Variance").Activate
        ActiveWindow.DisplayGridlines = False
        ActiveWindow.DisplayHeadings = False
        Application.DisplayFullScreen = True
        Application.DisplayAlerts = False
        For i = 1 To 1
            .Sheets("Sheet" & i).Delete
                
        .Colors = ThisWorkbook.Colors
                
        .SaveAs (NewName & ".xls")
       Next i
       End With
      
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
End Sub
Any help would be highly appreciated. Thank you in advance.</space></space>
 
Last edited:

Some videos you may like

Excel Facts

Repeat Last Command
Pressing F4 adds dollar signs when editing a formula. When not editing, F4 repeats last command.

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
Hi, May i expect the upgraded script. Charts as Chart No. 71 & Shape 53 is located in worksheet "Report" , Chart 24 and Shape 54 is located in worksheet Product Analysis, & Chart 35 and Shape 54 is located in worksheet Customer Analysis.

Please help me
 

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
May i expect to look into my thread and help me. Thank you in advance for your support. Any help would be highly appreciated.
 

Malhotra Rahul

Board Regular
Joined
Nov 10, 2017
Messages
82
So is there no way to copy the charts and objects to be added and paste them as picture with the provided script.
 

Watch MrExcel Video

Forum statistics

Threads
1,095,750
Messages
5,446,271
Members
405,393
Latest member
sully361

This Week's Hot Topics

Top