Pasting chart fails when outside of viewable screen area - vba

Whilst this proven method has worked for people and works for me in the general sense, I receive "Error 1004: Method 'Paste' of object '_Chart' failed." However, on the 5th iteration of the loop this method failure occurs. I have tried isolating each component of the Array and the 6th and 7th elements always fail, but when the 5th element is used in isolation or as the starting point of the loop it succeeds. I have also tried clearing the clipboard at different stages of the process to see if that helps and tested the object property of the "cht" object.
Sub PicturesCopy()
'Define path variables
Path = "C:\Users\khill\Documents\Macro Tests\"
PathSC = Path & "Master Cockpit\"
FileMCP = "Master_Daily sales cockpit.xlsm"
Set wbMCP = Workbooks(FileMCP)
Dim cht As ChartObject
Dim rngList, fileList As Variant
rngList = Array("B2:Y19", "B22:U39", "B43:O58", "B61:R76", "B81:J96", "B101:AD118", "B122:V139")
fileList = Array("Fig 1a", "Fig 1b", "Fig 2a", "Fig 2b", "Fig 2c", "Fig 3a", "Fig 3b")
For x = 0 To UBound(rngList)
'Application.CutCopyMode = True
With wbMCP.Worksheets("Graphs")
Debug.Print rngList(x)
Dim rgExp As Range: Set rgExp = .Range(rngList(x))
Debug.Print x
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
''' Create an empty chart with exact size of range copied
Set cht = wbMCP.Worksheets("Pictures").ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
cht.Name = "PicChart"
With cht
.Chart.Paste
Debug.Print fileList(x)
.Chart.Export "C:\Users\khill\Documents\Macro Tests\Pics\" & fileList(x) & ".jpg"
.Delete
'Application.CutCopyMode = False
End With
Set cht = Nothing
Set rgExp = Nothing
Next x
End Sub

Have you tried using a clipboard viewer to verify that the rgExp.CopyPicture operation has done what you expect when Debug.Print x shows 5 (6th iteration)?
Assuming you are using some version of Windows, there are some tips on how to view clipboard here, depending on version:
View & Manage Clipboard In Windows 10 / 8 / 7
http://www.thewindowsclub.com/windows-clipboard-manager-viewer

Ok. I found the problem. The charts have to be contained within the viewable screen to be pasted by the clipboard. so you can either zoom out (not ideal because the images are saved small and therefore pixelated) or zoom to the new Chart area/select the position where the chart object is placed in the first place. My solution was to zoom to the range. Adjusted Code is below. Hope this helps someone else :)
Sub PicturesCopy()
'Define path variables
Path = "C:\Users\khill\Documents\Macro Tests\"
PathSC = Path & "Master Cockpit\"
FileMCP = "Master_Daily sales cockpit.xlsm"
Set wbMCP = Workbooks(FileMCP)
Dim cht As ChartObject
Dim rngList, fileList As Variant
rngList = Array("B2:Y19", "B22:U39", "B43:O58", "B61:R76", "B81:J96", "B101:AD118", "B122:V139")
fileList = Array("Fig 1a", "Fig 1b", "Fig 2a", "Fig 2b", "Fig 2c", "Fig 3a", "Fig 3b")
For x = 0 To UBound(rngList)
'Application.CutCopyMode = True
With wbMCP.Worksheets("Graphs")
Debug.Print rngList(x)
Dim rgExp As Range: Set rgExp = .Range(rngList(x))
Debug.Print x
rgExp.CopyPicture Appearance:=xlScreen, Format:=xlPicture
End With
''' Create an empty chart with exact size of range copied
Set cht = wbMCP.Worksheets("Pictures").ChartObjects.Add(Left:=rgExp.Left, Top:=rgExp.Top, _
Width:=rgExp.Width, Height:=rgExp.Height)
cht.Name = "PicChart"
'Use ZoomToRange sub to re-size the window as appropriate
ZoomToRange ZoomThisRange:=Range(rngList(x)), PreserveRows:=True
With cht
.Chart.Paste
Debug.Print fileList(x)
.Chart.Export "C:\Users\khill\Documents\Macro Tests\Pics\" & fileList(x) & ".jpg"
.Delete
'Application.CutCopyMode = False
End With
Set cht = Nothing
Set rgExp = Nothing
Next x
End Sub
The ZoomToRange macro that is called in the above is as follows:
Sub ZoomToRange(ByVal ZoomThisRange As Range, _
ByVal PreserveRows As Boolean)
'###################################
'This macro resizes the window and''
'zoom properties to be appropriate''
'for our use''''''''''''''''''''''''
'###################################
'Turn alerts and screen updating off
Application.DisplayAlerts = False
Application.ScreenUpdating = False
'Declare variable type
Dim Wind As Window
'Create variable for window
Set Wind = ActiveWindow
'Zooming to specified range set to true
Application.GoTo ZoomThisRange(1, 1), True
'Select the resized range
With ZoomThisRange
If PreserveRows = True Then
.Resize(.Rows.Count, 1).Select
Else
.Resize(1, .Columns.Count).Select
End If
End With
'Set zoom and visible range to specified range
With Wind
.Zoom = True
.VisibleRange(1, 1).Select
End With
End Sub

Related

Copy and paste large number of charts from Excel to PowerPoint via VBA

The task is to loop through an Excel workbook with multiple sheets and copy all the charts contained in the workbook into a PowerPoint presentation, one chart per slide and always the same layout.
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
ch.Copy
With pptSlide.Shapes.Paste
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
The code works on my example (2 sheets, 3 charts total) but not if I apply it to the real thing, which is a workbook with 10-15 sheets and 8 charts per sheet. At some (random?) point, the code stops and gives me this error.
Run-time error:
Shapes (unknown member): Invalid request. Clipboard is empty or contains data which may not be pasted here.
I noted that the code crashed earlier, the more objects I put on the slides (which is why I left the text and the box in my example, although not strictly neccessary). Given that and the error message, I assumed the clipboard might not be cleared properly after each loop, so I put in a section to clear the clipboard but it didn't solve the issue.
After the chart is copied, try adding DoEvents and pausing the macro for a few seconds before pasting it into your slide. And the same thing after it's pasted into your slide.
So, for example, first add the following function to pause your code . . .
Sub PauseMacro(ByVal secs As Long)
Dim endTime As Single
endTime = Timer + secs
Do
DoEvents
Loop Until Timer > endTime
End Sub
Then try something like this . . .
ch.Copy
DoEvents
PauseMacro 5 'pause for 5 seconds
With pptSlide.Shapes.Paste
DoEvents
PauseMacro 5 'pause for 5 seconds
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
You may find through testing that you can pause for less than 5 seconds, maybe 3 seconds.
My approach is to split out potentially time-consuming operations into separate functions (see "'' Call as a Function" below). When a function is called, and then has to return, it seems that Excel/VBA/the-little-green-men-running-everything make sure that whatever operation it is waits until the operation is finished (the chart is totally added to the clipboard, the clipboard contents are totally pasted, the shape is totally instantiated, etc.) before continuing.
This also means not necessarily forcing a delay during execution that might not be needed (the Do Until or Loop Until or Wait that is often suggested).
So your code might look like this (caveat: untested)
Sub PPT_Example()
Dim pptApp As PowerPoint.Application
Dim pptPres As PowerPoint.Presentation
Dim sh As Worksheet
Dim ch As ChartObject
Set pptApp = New PowerPoint.Application
pptApp.Visible = True
Set pptPres = pptApp.Presentations.Add
pptPres.PageSetup.SlideSize = PpSlideSizeType.ppSlideSizeOnScreen16x9
For Each sh In ActiveWorkbook.Sheets
For Each ch In sh.ChartObjects
Dim pptSlide As Slide
Dim Title As Object
Dim Box As Object
Dim Txt As Object
Set pptSlide = NewSlide(pptPres) '' Call as a Function
ch.Copy
Dim shp As PowerPoint.Shape
Set shp = NewShape(pptSlide) '' Call as a Function
With shp
.Top = Application.CentimetersToPoints(3.3)
.Left = Application.CentimetersToPoints(0.76)
.Width = Application.CentimetersToPoints(16)
.Height = Application.CentimetersToPoints(10.16)
End With
'Insert Box
Set Box = NewBox(pptSlide) '' Call as a Function
Prop_Box.Name = "Box"
pptSlide.Shapes("Box").Fill.ForeColor.RGB = RGB(219, 233, 255)
pptSlide.Shapes("Box").Line.ForeColor.RGB = RGB(0, 102, 255)
'Insert the text box
Set Txt = NewTextBox(pptSlide) '' Call as a Function
Txt.Name = "Txt"
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Size = 14
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Bold = msoCTrue
pptSlide.Shapes("Txt").TextFrame.TextRange.Font.Name = "Arial"
pptSlide.Shapes("Txt").TextFrame.TextRange.Text = "Sample Text"
'Clear the Clipboard
Dim oData As New DataObject 'object to use the clipboard
oData.SetText Text:=Empty 'Clear
oData.PutInClipboard
Next
Next
End Sub
Function NewSlide(pptPres As PowerPoint.Presentation) As PowerPoint.Slide
Set NewSlide = pptPres.Slides.Add(pptPres.Slides.Count + 1, ppLayoutBlank)
End Function
Function NewShape(pptSlide As PowerPoint.Slide) As PowerPoint.Shape
Set NewShape = pptSlide.Shapes.Paste
End Function
Function NewBox(pptSlide As PowerPoint.Slide) As Object
Set Box = pptSlide.Shapes.AddShape(Type:=msoShapeRectangle, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function
Function NewTextBox(pptSlide As PowerPoint.Slide) As Object
Set NewTextBox = pptSlide.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
Left:=Application.CentimetersToPoints(17.1), _
Top:=Application.CentimetersToPoints(3.3), _
Width:=Application.CentimetersToPoints(7.22), _
Height:=Application.CentimetersToPoints(9.29))
End Function

How to make a range bar chart

Hey I'm new to forums and this is my first post. I am new to vba in excel, but have written thinkscript in ThinkorSwim.
If anyone is familiar with a range stock chart, thats what Im going after.
I found code for a line chart, and am using it, but it is based on where price is at any given time. I want to modify this line chart to only plot values when they are above or below a range so that it resembles a candlestick chart with no wicks. Once data enters that range, I only want it to update whenever a new high or low is made in that range. The ranges need to be preset (ex. 50 ticks) Once the range is exceeded, I want the data plotted in the next range up, and repeat the process. Time and dates should be ignored, and only plot based on price action.
Does anyone have any ideas?
Option Explicit
'Update the values between the quotes here:
Private Const sChartWSName = "Chart"
Private Const sSourceWSName = "Sheet1"
Private Const sTableName = "tblValues"
Public RunTime As Double
Private Sub Chart_Setup()
'Create the structure needed to preserve and chart data
Dim wsChart As Worksheet
Dim lstObject As ListObject
Dim cht As Chart
Dim shp As Button
'Create sheet if necessary
Set wsChart = Worksheets.Add
wsChart.Name = sChartWSName
'Set up listobject to hold data
With wsChart
.Range("A1").Value = "Time"
.Range("B1").Value = "Value"
Set lstObject = .ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=.Range("A1:B1"), _
xllistobjecthasheaders:=xlYes)
lstObject.Name = sTableName
.Range("A2").NumberFormat = "h:mm:ss AM/PM (mmm-d)"
.Columns("A:A").ColumnWidth = 25
.Select
End With
'Create the chart
With ActiveSheet
.Shapes.AddChart.Select
Set cht = ActiveChart
With cht
.ChartType = xlLine
.SetSourceData Source:=Range(sTableName)
.PlotBy = xlColumns
.Legend.Delete
.Axes(xlCategory).CategoryType = xlCategoryScale
With .SeriesCollection(1).Format.Range
.Visible = msoTrue
.Weight = 1.25
End With
End With
End With
'Add buttons to start/stop the routine
Set shp = ActiveSheet.Buttons.Add(242.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Initialize"
.Characters.Text = "Restart Plotting"
End With
Set shp = ActiveSheet.Buttons.Add(326.25, 0, 83.75, 33.75)
With shp
.OnAction = "Chart_Stop"
.Characters.Text = "Stop Plotting"
End With
End Sub
Public Sub Chart_Initialize()
'Initialize the routine
Dim wsTarget As Worksheet
Dim lstObject As ListObject
'Make sure worksheet exists
On Error Resume Next
Set wsTarget = Worksheets(sChartWSName)
If Err.Number <> 0 Then
Call Chart_Setup
Set wsTarget = Worksheets(sChartWSName)
End If
On Error GoTo 0
'Check if chart data exists
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count > 0 Then
Select Case MsgBox("You already have data. Do you want to clear it and start fresh?", vbYesNoCancel, "Clear out old data?")
Case Is = vbYes
'User wants to clear the data
lstObject.DataBodyRange.Delete
Case Is = vbCancel
'User cancelled so exit routine
Exit Sub
Case Is = vbNo
'User just wants to append to existing table
End Select
End If
'Begin appending
Call Chart_AppendData
End With
End Sub
Private Sub Chart_AppendData()
'Append data to the chart table
Dim lstObject As ListObject
Dim lRow As Long
With Worksheets(sChartWSName)
Set lstObject = .ListObjects(sTableName)
If lstObject.ListRows.Count = 0 Then
lRow = .Range("A1").End(xlDown).Row
End If
If lRow = 0 Then
lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1, 0).Row
End If
If lRow > 2 Then
If .Range("B" & lRow - 1).Value = Worksheets(sSourceWSName).Range("C10").Value Then
'Data is a match, so do nothing
Else
'Data needs appending
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("C10").Value
End If
Else
'Data needs appending
.Range("A" & lRow).Value = CDate(Now)
.Range("B" & lRow).Value = Worksheets(sSourceWSName).Range("C10").Value
End If
End With
RunTime = Now + TimeValue("00:00:01")
Application.OnTime RunTime, "Chart_AppendData"
End Sub
Public Sub Chart_Stop()
'Stop capturing data
On Error Resume Next
Application.OnTime EarliestTime:=RunTime, Procedure:="Chart_AppendData", Schedule:=False
End Sub
Take your sheet of data and filter... example would be:
Columns("A:C").Sort key1:=Range("C2"), _
order1:=xlAscending, header:=xlYes
Sort info: https://msdn.microsoft.com/en-us/library/office/ff840646.aspx
You then can define to select your desired range. Assuming column A is x-axis and B is y-axis (where your parameters for modifying need to be assessed):
Dim High1 as integer
Dim Low1 as integer
High1 = Match(Max(B:B),B:B) 'This isn't tested, just an idea
Low1 = Match(Max(B:B)+50,B:B) 'Again, not tested
and using those defined parameters:
.Range(Cells(High1,1),Cells(Low1,2).Select
This should give an idea for High1/Low1, where you can work through how you want to define the row that the max value occurs.
You then CreateObject for the Chart you want, having selected the data range you are going to use.

VBA Type missmatch

I have wrote some VBA code which I was fairly happy with. It went through a list on a worksheet, switched to another and set a variable (and thus changed some graphs) and then opened word, copied in the graphs to various bookmarks and saved the document as the variable name.
It worked like a charm and I was a happy boy (saved a good week and a bit of work for someone). I have not touched it since - or the worksheets for that matter - opened it today and it is giving me a type missmatch on the first lot. I would really love some advice as it has left me scratching my head.
Public X As Integer
Public Y As String
Sub Macro2()
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Sheets("CPD data 13-14").Select
Range("A" & LoopCounter).Select
Y = Range("A" & LoopCounter).Value
'Change the chart values
Sheets("Pretty Display (2)").Select
Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
The error hits on the following line:
wordapp.ActiveDocument.Bookmarks("Graph1").Range = ActiveSheet.ChartObjects("Chart 3")
EDIT
As suggested I have updated my code not to use select so it now reads:
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
'Change the chart values
pd.Range("A1").Value = Y
'Open word template
Set wordapp = CreateObject("word.Application")
wordapp.documents.Open "LOCATION"
wordapp.Visible = True
wordapp.Activate
wordapp.ActiveDocument.Bookmarks("InstitutionName").Range = Y
wordapp.ActiveDocument.Bookmarks("Graph1").Range = pd.ChartObjects("Chart 3")
'Close document
Mystring = Replace(Y, " ", "")
wordapp.ActiveDocument.SaveAs Filename:="LOCATION" & Mystring & ".docx"
wordapp.Quit
Set wordapp = Nothing
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
I still get the same runtime error at the same point.
try this
Option Explicit
Public X As Integer
Public Y As String
Sub Macro2()
Dim wordApp As Object
Dim LoopCounter As Integer
Dim Mystring As String
Dim ws As Worksheet, pd As Worksheet
Set ws = Sheets("CPD data 13-14")
Set pd = Sheets("Pretty Display (2)")
'Set up variables that are required
Y = ""
LoopCounter = 2
' open one Word session for all the documents to be processed
Set wordApp = CreateObject("word.Application")
Do Until Y = "STOP"
'Grab the value from a list
Y = ws.Range("A" & LoopCounter).Value
With pd
.Range("A1").Value = Y 'Change the chart values
.ChartObjects("Chart 3").Copy ' Copy the chart
End With
'act on Word application
With wordApp
'open word template
.documents.Open "LOCATION"
.Visible = True
' paste into bookmarks, "save as" document and close it
With .ActiveDocument
.Bookmarks("InstitutionName").Range = Y
.Bookmarks("Graph1").Range.PasteSpecial
Mystring = Replace(Y, " ", "")
.SaveAs Filename:="LOCATION" & Mystring & ".docx"
.Close
End With
End With
'Increase count and loop
LoopCounter = LoopCounter + 1
Loop
'Close Word
wordApp.Quit
Set wordApp = Nothing
End Sub
I couldn't have a word "Range" object directly set to an Excel "Chart" object
So I had to copy the chart and use "PasteSpecial" method of the Word "Range" object
Furthemore I worked with one Word session only, which'd result in a faster job
Finally I also made some "comsetics" to make the code more readable/maintanable
just as a suggestion: I'd always use "Option Explicit" statement. that'll force you some extra work to explicitly declare each and every variable you use, but that will also give much more control over your work and result in less debbugging issues, thus saving time at the end
My advice is to set the Explicit flag and try to decompile the code. Any variables that you didn't dimension will throw an error. This is a good time to dimension the variable and type the data appropriately.
If that doens't throw an error, which it should since you have at least one variable LoopCounter that isn't dimensioned and could therefore cause data type errors then try changing Public X As Integer to Public X As Long so as to avoid values beyond the limit of the Integer data type.
.Activate is sometimes necessary even when using .Select from my experience. Selecting a worksheet should make it the active worksheet, but that's not always the case.

Delete chart series but keep their formatting

This is the code I use to dynamically create charts in Virtual Basic:
Dim Chart As Object
Set Chart = Charts.Add
With Chart
If bIssetSourceChart Then
CopySourceChart
.Paste Type:=xlFormats
End If
For Each s In .SeriesCollection
s.Delete
Next s
.ChartType = xlColumnClustered
.Location Where:=xlLocationAsNewSheet, Name:=chartTitle
Sheets(chartTitle).Move After:=Sheets(Sheets.count)
With .SeriesCollection.NewSeries
If Val(Application.Version) >= 12 Then
.values = values
.XValues = columns
.Name = chartTitle
Else
.Select
Names.Add "_", columns
ExecuteExcel4Macro "series.columns(!_)"
Names.Add "_", values
ExecuteExcel4Macro "series.values(,!_)"
Names("_").Delete
End If
End With
End With
#The CopySourceChart Sub:
Sub CopySourceChart()
If Not CheckSheet("Source chart") Then
Exit Sub
ElseIf TypeName(Sheets("Grafiek")) = "Chart" Then
Sheets("Grafiek").ChartArea.Copy
Else
Dim Chart As ChartObject
For Each Chart In Sheets("Grafiek").ChartObjects
Chart.Chart.ChartArea.Copy
Exit Sub
Next Chart
End If
End Sub
How can I keep the formatting of series that is applied in the If bIssetSourceChart part while deleting those series' data?
I have solved this issue before. I have charts that were created by macro but it only applied to the date I made them. So a made a refresh macro that runs after every Workbook open. I used source before and found that it deletes everything. then moved on to series only. I will paste my work here and try to explain. For quick navigation the second part of the code down there called sub aktualizacegrafu() might help you if you get lost find a reference in upper part of the code starting with sub generacegrafu()
Sub generacegrafu()
ThisWorkbook.Sheets("List1").CommandButton6.BackColor = &H0&
ThisWorkbook.Sheets("List1").CommandButton6.ForeColor = &HFFFFFF
Dim najdiposlradek As Object
Dim graf As Object
Dim vkladacistring As String
Dim vykreslenysloupec As Integer
Dim hledejsloupec As Object
Dim hledejsloupec2 As Object
Dim kvantifikator As Integer
Dim grafx As ChartObject
Dim shoda As Boolean
Dim jmenografu As String
Dim rngOrigSelection As Range
Cells(1, 1).Select
If refreshcharts = True Then
Set hledejsloupec = Range("11:11").Find(What:=prvnislovo, LookIn:=xlValues)
'dynamicaly generated, prvnislovo is for first word in graph and the macro looks for match in row 11 if it doesnt find any then
Else
'then it looks for match in option box
Set hledejsloupec = Range("11:11").Find(What:=ThisWorkbook.Sheets("List1").ComboBox1.Value, LookIn:=xlValues)
End If
If hledejsloupec Is Nothing Then
MsgBox "Zadaný sloupec v první nabídce nebyl nalezen."
Else
If refreshcharts = True Then
Set hledejsloupec2 = Range("11:11").Find(What:=druheslovo, LookIn:=xlValues)
Else
Set hledejsloupec2 = Range("11:11").Find(What:=ThisWorkbook.Sheets("List1").ComboBox2.Value, LookIn:=xlValues)
End If
If hledejsloupec2 Is Nothing Then
MsgBox "Zadaný sloupec v druhé nabídce nebyl nalezen."
Else
jmenografu = Cells(11, hledejsloupec.Column).Value & "_" & Cells(11, hledejsloupec2.Column).Value
Set najdiposlradek = Range("A:A").Find(What:=Date, LookIn:=xlValues)
Application.ScreenUpdating = False
Set rngOrigSelection = Selection
'This one selects series for new graph to be created
Cells(1048576, 16384).Select
Set graf = ThisWorkbook.Sheets("List1").Shapes.AddChart
rngOrigSelection.Parent.Parent.Activate
rngOrigSelection.Parent.Select
rngOrigSelection.Select 'trouble with annoing excel feature to unselect graphs
Application.ScreenUpdating = True
graf.Select
kvantifikator = 1
Do
shoda = False
For Each grafx In ThisWorkbook.Sheets("List1").ChartObjects
If grafx.Name = jmenografu Then
shoda = True
jmenografu = jmenografu & "(" & kvantifikator & ")"
kvantifikator = kvantifikator + 1
End If
Next grafx
'this checks if graph has younger brother in sheet
'but no we get to the part that matter do not bother playing with source of the graph because I have found it is quite hard to make it work properly
Loop Until shoda = False
'here it starts
ActiveChart.Parent.Name = jmenografu
ActiveChart.SeriesCollection.NewSeries 'add only series!
vkladacistring = "=List1!R12C" & hledejsloupec.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec.Column 'insert this into series
ActiveChart.SeriesCollection(1).Values = vkladacistring
vkladacistring = "=List1!R11C" & hledejsloupec.Column
ActiveChart.SeriesCollection(1).Name = vkladacistring
vkladacistring = "=List1!R12C" & hledejsloupec2.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec2.Column
ActiveChart.SeriesCollection(1).XValues = vkladacistring
'here it ends and onward comes formating
ActiveChart.Legend.Delete
ActiveChart.ChartType = xlConeColClustered
ActiveChart.ClearToMatchStyle
ActiveChart.ChartStyle = 41
ActiveChart.ClearToMatchStyle
ActiveSheet.Shapes(jmenografu).Chart.ChartArea.Format.ThreeD.RotationY = 90
ActiveSheet.Shapes(jmenografu).Chart.ChartArea.Format.ThreeD.RotationX = 0
ActiveChart.Axes(xlValue).MajorUnit = 8.33333333333333E-02
ActiveChart.Axes(xlValue).MinimumScale = 0.25
ActiveChart.Walls.Format.Fill.Visible = msoFalse
ActiveChart.Axes(xlCategory).MajorUnitScale = xlMonths
ActiveChart.Axes(xlCategory).MajorUnit = 1
ActiveChart.Axes(xlCategory).BaseUnit = xlDays
End If
End If
Call aktualizacelistboxu
ThisWorkbook.Sheets("List1").CommandButton6.BackColor = &H8000000D
ThisWorkbook.Sheets("List1").CommandButton6.ForeColor = &H0&
End Sub
the result i found is that you cannot keep formating completely when you close chart because source of chart doesnt work very well and when you delete it some format will be lost
I will post my actualization of chart as well
Sub aktualizacegrafu()
Dim grafx As ChartObject
Dim hledejsloupec As Object
Dim hledejsloupec2 As Object
Dim vkladacistring As String
Dim najdiposlradek As Object
For Each grafx In ThisWorkbook.Sheets("List1").ChartObjects
prvnislovo = Left(grafx.Name, InStr(1, grafx.Name, "_") - 1)
druheslovo = Right(grafx.Name, Len(grafx.Name) - InStr(1, grafx.Name, "_"))
'now it checks the names of charts .. the data loads from respective columns that are named the same way so I ussualy choose what statistic I want by choosing the columns needed
'for example I want to reflect my arrivals to work according to the hours I worked or to the date so I set 1st option to arrival and 2nd to date
grafx.Activate
Set najdiposlradek = Range("A:A").Find(What:=Date, LookIn:=xlValues)
Set hledejsloupec = Range("11:11").Find(What:=prvnislovo, LookIn:=xlValues)
If hledejsloupec Is Nothing Then
MsgBox "Hodnota v grafu již není mezi sloupci v tabulce. Aktualizace grafu " & grafx.Name & " bude ukončena."
Else
Set hledejsloupec2 = Range("11:11").Find(What:=druheslovo, LookIn:=xlValues)
If hledejsloupec2 Is Nothing Then
MsgBox "Hodnota v grafu již není mezi sloupci v tabulce. Aktualizace grafu " & grafx.Name & " bude ukončena."
Else
here it enters string that contains adress of desired cell I always enter it as string cause its easier to see with debug.print what is being entered
result looks like this List means Sheet in czech
activechart.seriescollection(1).values=List1!R12C1:R13C16
activechart.seriescollection(1).name=List1!R1C1:R1C15
vkladacistring = "=List1!R12C" & hledejsloupec.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec.Column
ActiveChart.SeriesCollection(1).Values = vkladacistring
vkladacistring = "=List1!R11C" & hledejsloupec.Column
ActiveChart.SeriesCollection(1).Name = vkladacistring
vkladacistring = "=List1!R12C" & hledejsloupec2.Column & ":R" & najdiposlradek.Row & "C" & hledejsloupec2.Column
ActiveChart.SeriesCollection(1).XValues = vkladacistring
End If
End If
Next grafx
Call aktualizacelistboxu
End Sub
so result of this is when you actually have a chart already but want to make slight changes to the area it applies to then it keeps the formating
hope this helped a bit if not I am sorry if it did keep the revard. It just got me curious because I was solving the same problem recently
if you need any further explanation comment this and I will try to explain

Displaying only a determined range of data

I want to display to the user certain information that exists on a separated worksheet, whenever he clicks a button.
I can set Excel to "go" to this worksheet at the starting line of the range , but I could not find a way to hide everything else.
Is there some method for this, or do I have to hide all rows and columns?
Insert a UserForm in the Workbook's VB Project.
Add a ListBox control to the userform.
Then do something like this code in the UserForm_Activate event code:
Private Sub UserForm_Activate()
Dim tbl As Range
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
Me.Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With ListBox1
.ColumnHeads = False
.ColumnCount = tbl.Columns.Count
.RowSource = tbl.Address
End With
End Sub
Which gives unformatted data from the range:
To export the range as an image, you could create an Image in the UserForm instead of a Listbox. Then this should be enough to get you started.
As you can see from this screenshot, the image might not always come out very clearly. Also, if you are working with a large range of cells, the image might not fit on your userform, etc. I will leave figuring that part out up to you :)
Private Sub UserForm_Activate()
Dim tbl As Range
Dim imgPath As String
Set tbl = Range("B2:E7") '## Change this to capture the rang you need '
imgPath = Export_Range_Images(tbl)
Caption = "Displaying data from " & _
ActiveSheet.Name & "!" & tbl.Address
With Image1
If Not imgPath = vbNullString Then
.Picture = LoadPicture(imgPath)
.PictureSizeMode = fmPictureSizeModeClip
.PictureAlignment = 2 'Center
.PictureTiling = False
.SpecialEffect = 2 'Sunken
End If
End With
End Sub
Function Export_Range_Images(rng As Range) As String
'## Modified by David Zemens with
' credit to: _
' http://vbadud.blogspot.com/2010/06/how-to-save-excel-range-as-image-using.html ##'
Dim ocht As Object
Dim srs As Series
rng.CopyPicture xlScreen, xlPicture
ActiveSheet.Paste
Set ocht = ActiveSheet.Shapes.AddChart
For Each srs In ocht.Chart.SeriesCollection
srs.Delete
Next
'## Modify this line as needed ##'
fname = "C:\users\david_zemens\desktop\picture.jpg"
On Error Resume Next
Kill fname
On Error GoTo 0
ocht.Width = rng.Width
ocht.Height = rng.Height
ocht.Chart.Paste
ocht.Chart.Export Filename:=fname, FilterName:="JPG"
Application.DisplayAlerts = False
ocht.Delete
Application.DisplayAlerts = True
Set ocht = Nothing
Export_Range_Images = fname
End Function
If you record a macro and hide some columns and rows manually, the code will be produced for you, and you will see how it's done.