convert Chart to picture

AwesomeSteph

Board Regular
Joined
Aug 18, 2017
Messages
80
I need to generate a report by pressing a button.
I use VBA to extract worksheets to a new workbook using a button a lot, but this one I can't figure out.
What I would like is for the 2 charts on the active sheet to not be charts with links on the new sheet (so the report that can be provided to the customer doesn't have file paths etc.) any help would be greatly appreciated!
I also have a part of code that I feel could be simplified I use it in a lot of stuff and it takes a while to do, it works but could it be easier to make all formulas in the sheet to values in the new one?

Code:
Sub RipTABSseparateFILES()
Dim wbThis As Workbook
Dim wbNew As Workbook
Dim ws As Worksheet
Dim strFilename As String


        Application.DisplayAlerts = False
        Application.ScreenUpdating = False
    Set wbThis = ThisWorkbook
    For Each ws In wbThis.Worksheets
        Select Case ws.Name
            Case "Deleted", "Combined Status", "Assignment", "Data Sheet"
            Case Else
    
    Set wbThis = ThisWorkbook
        strFilename = wbThis.Path & "/" & ws.Name
        ws.Copy
        Set wbNew = ActiveWorkbook
        
        If ws.Name = "Burn Chart (split)" Then
            Range("C5").Value = Evaluate("C5")
            Range("C6").Value = Evaluate("C6")
            Range("C7").Value = Evaluate("C7")
            Range("D5").Value = Evaluate("D5")
            Range("D6").Value = Evaluate("D6")
            Range("D7").Value = Evaluate("D7")
            Range("C9").Value = Evaluate("C9")
            Range("C10").Value = Evaluate("C10")
            Range("C11").Value = Evaluate("C11")
            Range("D9").Value = Evaluate("D9")
            Range("D10").Value = Evaluate("D10")
            Range("D11").Value = Evaluate("D11")
            Range("C13").Value = Evaluate("C13")
            Range("C14").Value = Evaluate("C14")
            Range("C15").Value = Evaluate("C15")
            Range("D13").Value = Evaluate("D13")
            Range("D14").Value = Evaluate("D14")
            Range("D15").Value = Evaluate("D15")
            Range("C17").Value = Evaluate("C17")
            Range("C18").Value = Evaluate("C18")
            Range("C19").Value = Evaluate("C19")
            Range("D17").Value = Evaluate("D17")
            Range("D18").Value = Evaluate("D18")
            Range("D19").Value = Evaluate("D19")
            Range("C21").Value = Evaluate("C21")
            Range("C22").Value = Evaluate("C22")
            Range("C23").Value = Evaluate("C23")
            Range("D21").Value = Evaluate("D21")
            Range("D22").Value = Evaluate("D22")
            Range("D23").Value = Evaluate("D23")
            Range("C25").Value = Evaluate("C25")
            Range("C26").Value = Evaluate("C26")
            Range("C27").Value = Evaluate("C27")
            Range("C28").Value = Evaluate("C28")
            Range("C29").Value = Evaluate("C29")
            Range("C30").Value = Evaluate("C30")
            Range("C31").Value = Evaluate("C31")
            Range("C32").Value = Evaluate("C32")
            Range("C33").Value = Evaluate("C33")
            Range("D25").Value = Evaluate("D25")
            Range("D26").Value = Evaluate("D26")
            Range("D27").Value = Evaluate("D27")
            Range("D28").Value = Evaluate("D28")
            Range("D29").Value = Evaluate("D29")
            Range("D30").Value = Evaluate("D30")
            Range("D31").Value = Evaluate("D31")
            Range("D32").Value = Evaluate("D32")
            Range("D33").Value = Evaluate("D33")
            End If


        wbNew.ActiveSheet.Shapes("CommandButton1").Delete
        wbNew.SaveAs strFilename & ActiveSheet.Range("B2")
        wbNew.Close
        End Select
        Next ws
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True


End Sub
 

Excel Facts

How to find 2nd largest value in a column?
MAX finds the largest value. =LARGE(A:A,2) will find the second largest. =SMALL(A:A,3) will find the third smallest
Some possible streamlining

Code:
Option Explicit

Sub RipTABSseparateFILES()
    Dim wbThis As Workbook
    Dim wbNew As Workbook
    Dim ws As Worksheet
    Dim strFilename As String
    
    Dim rngCell As Range

    
    Application.ScreenUpdating = False
    
    Set wbThis = ThisWorkbook
    For Each ws In wbThis.Worksheets
        Select Case ws.Name
        Case "Deleted", "Combined Status", "Assignment", "Data Sheet"
        Case Else
            Set wbThis = ThisWorkbook
            strFilename = wbThis.Path & "/" & ws.Name
            ws.Copy
            Set wbNew = ActiveWorkbook
            
            If ws.Name = "Burn Chart (split)" Then
                For Each rngCell In Range("C5:D7,C9:D11,C13:D15,C17:D19,C21:D23,C25:D33").Cells
                    rngCell.Value = Evaluate(rngCell)
                Next
            End If
            
            Application.DisplayAlerts = False   'Limit no alerts to the smallest area possible
            With wbNew
                .ActiveSheet.Shapes("CommandButton1").Delete
                .SaveAs strFilename & ActiveSheet.Range("B2")
                .Close
            End With
            Application.DisplayAlerts = True
            
        End Select
    Next ws
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True


End Sub



Sub ExportChartToFile()
    ActiveSheet.ChartObjects(1).Chart.Export Filename:=sSaveDir & strFileNameExt & ".png", Filtername:="PNG"
End Sub


Any reason why this wouldn't work?
Code:
            If ws.Name = "Burn Chart (split)" Then
                With Range("C5:D33")
                    .Copy
                    .PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
                Next
            End If
 
Last edited:
Upvote 0

Forum statistics

Threads
1,223,227
Messages
6,170,849
Members
452,361
Latest member
d3ad3y3

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top