Can someone please help me:
understand what is happening in this code bit:
With objOLE
.Name = sCaption
.Top = rngCell.Top
.Left = rngCell.Left
understand what action I need to take to stop the code from breaking on the .Top = rngCell.Top line. I have been running this code for months and never had a problem until today. Suddenly the code is breaking on
.Top = rngCell.Top
...and giving me a Runtime error 91: Object Variable or With Block Variable not set:
sFileName = Dir(strInitialFolder & "*.pdf")
Do While Len(sFileName) > 0
If Right(sFileName, 3) = "pdf" Then
Select Case Left(sFileName, 3)
Case "HCM"
Set rngCell = ActiveSheet.Range("B25")
sCaption = "HCM_Summary_PDF"
Case "CTS"
Set rngCell = ActiveSheet.Range("C25")
sCaption = "CTS_Summary_PDF"
End Select
Set objOLE = ActiveSheet.OLEObjects.Add(Filename:=strInitialFolder & sFileName, Link:=False, DisplayAsIcon:=True, _
IconFileName:=icoPDF, IconIndex:=0, IconLabel:=sFileName)
With objOLE
.name = sCaption
.Top = rngCell.Top
.Left = rngCell.Left '.Verb
End With
End If
'Set the fileName to the next available file
sFileName = Dir
Loop
Thanks!
Related
After a recent Office 365 update, my code to copy tables from Excel to Power Point stopped working.
Previous code:
Sub GeneratePresentation()
Dim pptApp As PowerPoint.Application
Dim pptPrez As PowerPoint.Presentation
Dim pSlide As PowerPoint.Slide
Dim objPPT As Object
Dim myRange As Excel.Range
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
MonthNo = Month(Worksheets("inputs").Range("B3"))
MonthData = Worksheets("inputs").Cells(MonthNo + 10, 9)
If MonthData = "" Then
MsgBox "Please update losses"
Else
FilePath = "\\Model\"
Filename = "Template Monthly reports.pptx"
file = FilePath & Filename
Set pptPrez = objPPT.Presentations.Open(file)
Set pptApp = GetObject(Class:="PowerPoint.Application")
Set pptPrez = pptApp.ActivePresentation
'Slide 1 title 1
Set pSlide = pptPrez.Slides(1)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
Set osh = pSlide.Shapes.PasteSpecial(ppPasteDefault)(1)
With osh
.Top = 160
.Left = 135
.Height = 80
.Width = 550
End With
Code continues to paste tables and pictures. then
End if
End sub
I get the following error:
VBA error Run-time '-2147188160 (80048240)': Shapes (unknown member)
I have tried most variants of paste but it only lets me paste pictures or text. I noticed that the VBA refernce library revision seems to have reduced to Microsoft PowerPoint 14.0 Object library when I am fairly sure it was build 15 or 16 before. Would this be the cause?
I have come up with a solution which is to use
'Slide 1 title 1
i = 1
Set pSlide = pptPrez.Slides(i)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" & Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
pptPrez.Windows(1).Activate
pptPrez.Windows(1).View.GotoSlide i
pptPrez.Slides(i).Shapes("Title").Select
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
With pptPrez.Slides(i)
With .Shapes("Title")
.LockAspectRatio = msoFalse
.Top = 160
.Left = 135
.Height = 70
.Width = 550
'.TextFrame.TextRange.Font.Name = "Futura Bold"
'.TextFrame.TextRange.Font.Size = 24
'.TextFrame.TextRange.ParagraphFormat.Alignment = ppAlignLeft
'.TextFrame.TextRange.ParagraphFormat.WordWrap = msoTrue
End With
End With
For the alternative, I have to create all the tables manually then name them and select them in the code which works, but it seems less consistent and reliable requiring the windows to be active being more to go wrong.
Any ideas how to get the first code working again? I can paste manually still but it seems not using pastespecial. Why would an update remove this ability? I've tried proven code from this forum using this paste function but it won't work either which used to, It's definitely the update as all our computers now have the same issue which I find hard to believe too.
I decided to write an answer instead of a bunch of comments, since I wanted to post my code.
Those Office 365 updates have caught me a time or three. But I don't know what's the problem.
The code fails on PasteSpecial? PasteSpecial is a relative newcomer to PowerPoint VBA, but I thought it was around for Office 14 (2010). The reference to version 14.0 of the PowerPoint library is strange. Can you go to Tools > References and scroll to version 16.0? If so, check that one instead. What version of Office are you using: go to File tab > Account, and find the version number and build number.
Why do you have both CreateObject and GetObject. For PowerPoint, you only need to do this once, using CreateObject. If PowerPoint is running, CreateObject returns the running instance; if not, it returns a new instance. Probably not important, but it adds clutter. Move CreateObject up to where GetObject is, and change objPPT to pptApp (since you don't need both).
Also, you've used three variables which are not declared. Declare MonthNo and MonthData as Variant and osh as PowerPoint.Shape (actually, in my code I renamed it pptShape and pSlide to pptSlide for consistency).
With the additional modification to use the active presentation instead of opening one at a given path and file name, your code works fine for me. I'm running Version 1711, Build 8711.2037, for what it's worth.
And here's the code that ran fine for me.
Sub GeneratePresentation()
Dim pptApp As PowerPoint.Application
Dim pptPrez As PowerPoint.Presentation
Dim pptSlide As PowerPoint.Slide
Dim myRange As Excel.Range
Dim pptShape As PowerPoint.Shape
Dim MonthNo As Variant
Dim MonthData As Variant
MonthNo = Month(Worksheets("inputs").Range("B3"))
MonthData = Worksheets("inputs").Cells(MonthNo + 10, 9)
If MonthData = "" Then
MsgBox "Please update losses"
Else
Set pptApp = GetObject(Class:="PowerPoint.Application")
Set pptPrez = pptApp.ActivePresentation
'' JP - use active presentation instead of opening one
''FilePath = "\\Model\"
''Filename = "Template Monthly reports.pptx"
''file = FilePath & Filename
''Set pptPrez = objPPT.Presentations.Open(file)
Set pptPrez = pptApp.ActivePresentation
'Slide 1 title 1
Set pptSlide = pptPrez.Slides(1)
Sheets("01").Range("D3") = "= ""Midstream Monthly Production Report "" _
& Text(Inputs!B3, ""Mmmm YYYY"") & "" - internal"""
Sheets("01").Range("D3").Copy
Set pptShape = pptSlide.Shapes.PasteSpecial(ppPasteDefault)(1)
With pptShape
.Top = 160
.Left = 135
.Height = 80
.Width = 550
End With
End If
End Sub
I have updated the alternative solution which might help others as it does a few things; copies tables to an existing presentation and slides updating old shapes and new shapes, copies pictures to new slides with a pop up box to allow a choice in pasting a table.
I made a function to do this to reduce the main code and make it easier to manage as I had dozens of copies and pastes. I haven't pasted everything but showed some of the different ways to paste:
Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As LongPtr)
Private pptApp As PowerPoint.Application
Private pptPres As PowerPoint.Presentation
Private pSlide As PowerPoint.Slide
Private TTop, TLeft As Variant
Private TableCount, SlideNo As Integer
Private MyRange As Excel.Range
Private ShapeName As String
Private Function CreateTable()
Dim l As Long
Set pSlide = pptPres.Slides(SlideNo)
MyRange.Copy
pptPres.Windows(1).Activate
pptPres.Windows(1).View.GotoSlide SlideNo
With pptPres.Slides(SlideNo)
If ShapeName = isblank Then
Else
pptPres.Slides(SlideNo).Shapes(ShapeName).Select
End If
For l = 1 To 100
DoEvents
Next l
pptApp.CommandBars.ExecuteMso ("PasteSourceFormatting")
For l = 1 To 500
DoEvents
Next l
pptApp.CommandBars.ReleaseFocus
NoShapes = pSlide.Shapes.Count
If ShapeName = isblank Then
pptPres.Slides(SlideNo).Shapes(NoShapes).Name = "Table" & TableCount
pptPres.Slides(SlideNo).Shapes(ShapeName).Select
With .Shapes("Table" & TableCount)
.LockAspectRatio = msoFalse
If TTop = isblank Then
Else
.Top = TTop
End If
If TLeft = isblank Then
Else
.Left = TLeft
End If
End With
TableCount = TableCount + 1
Else
End If
End With
ShapeName = ""
TLeft = ""
TTop = ""
Application.CutCopyMode = False
End Function
Sub GeneratePresentation()
Dim FilePath, Filename, file As String
Dim MonthNo, MonthData As Variant
Dim x, y As Variant
Dim UpdateRecords As Integer
Dim WB As Excel.Workbook
FilePath = "\\\Model\"
Filename = "Template Weekly Report.pptx"
file = FilePath & Filename
Set pptApp = New PowerPoint.Application
Set pptPres = pptApp.Presentations.Open(file) ' using a specific presentation or template
Set pptPres = pptApp.ActivePresentation
TableCount = 1
'Slide 1 title 1
SlideNo = 1
Sheets("01").Range("D3") = "= ""Weekly Report """
Sheets("01").Range("D4") = "= ""For Week No. ""&TEXT(WEEKNUM(NOW(),16),""#"")& "" - internal"""
Set MyRange = Sheets("0" & SlideNo).Range("D3:D4")
TTop = 160
TLeft = 135
Call CreateTable
'Slide 1 title 2
Sheets("01").Range("D7").Formula = "=DAY(Entry!B4)&LOOKUP(DAY(Entry!B4),{1,2,3,4,21,22,23,24,31;""st"",""nd"",""rd"",""th"",""st"",""nd"",""rd"",""th"",""st""})&TEXT(Entry!B4,"" mmmm yyy"")"
Set MyRange = Sheets("0" & SlideNo).Range("D7")
TTop = 280
TLeft = 135
Call CreateTable
'slide 2 table 1
SlideNo = 2
Set MyRange = Sheets("0" & SlideNo).Range("B33:T40")
TTop = 380
Call CreateTable
'Slide 2 chart 1
ActiveWorkbook.Sheets("0" & SlideNo).ChartObjects("Chart 1").Copy
Set osh = pSlide.Shapes.PasteSpecial(ppPasteMetafilePicture)(1)
With osh
.Top = 98
.Left = 35
.Width = 430
End With
'Slide 3 table 1
SlideNo = 3
Set pSlide = pptPres.Slides(SlideNo)
UpdateRecords = MsgBox("Update Records", vbYesNo, "Update Records?")
If UpdateRecord = yes Then
Set MyRange = Sheets("0" & SlideNo).Range("E17:I20")
TTop = 330
Call CreateTable
Else
End If
pptPres.Windows(1).Activate
pptPres.Windows(1).View.GotoSlide 1
End Sub
I hope this is helpful.
If you have any recommendation let me know.
Jon
I'm adding ".jpg" files to my Excel sheet with the code below :
'Add picture to excel
xlApp.Cells(i, 20).Select
xlApp.ActiveSheet.Pictures.Insert(picPath).Select
'Calgulate new picture size
With xlApp.Selection.ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
'Resize and make printable
With xlApp.Selection
.Placement = 1 'xlMoveAndSize
'.Placement = 2 'xlMove
'.Placement = 3 'xlFreeFloating
.PrintObject = True
End With
I don't know what I am doing wrong but it doesn't get inserted into the right cell, so what should I do to put this picture into a specified cell in Excel?
Try this:
With xlApp.ActiveSheet.Pictures.Insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 75
.Height = 100
End With
.Left = xlApp.ActiveSheet.Cells(i, 20).Left
.Top = xlApp.ActiveSheet.Cells(i, 20).Top
.Placement = 1
.PrintObject = True
End With
It's better not to .select anything in Excel, it is usually never necessary and slows down your code.
Looking at posted answers I think this code would be also an alternative for someone. Nobody above used .Shapes.AddPicture in their code, only .Pictures.Insert()
Dim myPic As Object
Dim picpath As String
picpath = "C:\Users\photo.jpg" 'example photo path
Set myPic = ws.Shapes.AddPicture(picpath, False, True, 20, 20, -1, -1)
With myPic
.Width = 25
.Height = 25
.Top = xlApp.Cells(i, 20).Top 'according to variables from correct answer
.Left = xlApp.Cells(i, 20).Left
.LockAspectRatio = msoFalse
End With
I'm working in Excel 2013. Also realized that You need to fill all the parameters in .AddPicture, because of error "Argument not optional". Looking at this You may ask why I set Height and Width as -1, but that doesn't matter cause of those parameters are set underneath between With brackets.
Hope it may be also useful for someone :)
If it's simply about inserting and resizing a picture, try the code below.
For the specific question you asked, the property TopLeftCell returns the range object related to the cell where the top left corner is parked. To place a new image at a specific place, I recommend creating an image at the "right" place and registering its top and left properties values of the dummy onto double variables.
Insert your Pic assigned to a variable to easily change its name. The Shape Object will have that same name as the Picture Object.
Sub Insert_Pic_From_File(PicPath as string, wsDestination as worksheet)
Dim Pic As Picture, Shp as Shape
Set Pic = wsDestination.Pictures.Insert(FilePath)
Pic.Name = "myPicture"
'Strongly recommend using a FileSystemObject.FileExists method to check if the path is good before executing the previous command
Set Shp = wsDestination.Shapes("myPicture")
With Shp
.Height = 100
.Width = 75
.LockAspectRatio = msoTrue 'Put this later so that changing height doesn't change width and vice-versa)
.Placement = 1
.Top = 100
.Left = 100
End with
End Sub
Good luck!
I have been working on a system that ran on a PC and Mac and was battling to find code that worked for inserting pictures on both PC and Mac. This worked for me so hopefully someone else can make use of it!
Note: the strPictureFilePath and strPictureFileName variables need to be set to valid PC and Mac paths Eg
For PC: strPictureFilePath = "E:\Dropbox\" and strPictureFileName = "TestImage.jpg" and with Mac: strPictureFilePath = "Macintosh HD:Dropbox:" and strPictureFileName = "TestImage.jpg"
Code as Follows:
On Error GoTo ErrorOccured
shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Select
ActiveSheet.Pictures.Insert(Trim(strPictureFilePath & strPictureFileName)).Select
Selection.ShapeRange.Left = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Left
Selection.ShapeRange.Top = shtRecipeBrowser.Cells(intDestinationRecipeRowCount, 1).Top + 10
Selection.ShapeRange.LockAspectRatio = msoTrue
Selection.ShapeRange.Height = 130
Firstly, of all I recommend that the pictures are in the same folder as the workbook.
You need to enter some codes in the Worksheet_Change procedure of the worksheet. For example, we can enter the following codes to add the image that with the same name as the value of cell in column A to the cell in column D:
Private Sub Worksheet_Change(ByVal Target As Range)
Dim pic As Picture
If Intersect(Target, [A:A]) Is Nothing Then Exit Sub
On Error GoTo son
For Each pic In ActiveSheet.Pictures
If Not Application.Intersect(pic.TopLeftCell, Range(Target.Offset(0, 3).Address)) Is Nothing Then
pic.Delete
End If
Next pic
ActiveSheet.Pictures.Insert(ThisWorkbook.Path & "\" & Target.Value & ".jpg").Select
Selection.Top = Target.Offset(0, 2).Top
Selection.Left = Target.Offset(0, 3).Left
Selection.ShapeRange.LockAspectRatio = msoFalse
Selection.ShapeRange.Height = Target.Offset(0, 2).Height
Selection.ShapeRange.Width = Target.Offset(0, 3).Width
son:
End Sub
With the codes above, the picture is sized according to the cell it is added to.
Details and sample file here : Vba Insert image to cell
I tested both #SWa and #Teamothy solution. I did not find the Pictures.Insert Method in the Microsoft Documentations and feared some compatibility issues. So I guess, the older Shapes.AddPicture Method should work on all versions. But it is slow!
On Error Resume Next
'
' first and faster method (in Office 2016)
'
With ws.Pictures.Insert(Filename:=imageFileName, LinkToFile:=msoTrue, SaveWithDocument:=msoTrue)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
.Left = destRange.Left
.Top = destRange.Top
.Placement = 1
.PrintObject = True
.Name = imageName
End With
'
' second but slower method (in Office 2016)
'
If Err.Number <> 0 Then
Err.Clear
Dim myPic As Shape
Set myPic = ws.Shapes.AddPicture(Filename:=imageFileName, _
LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=destRange.Left, Top:=destRange.Top, Width:=-1, height:=destRange.height)
With myPic.OLEFormat.Object.ShapeRange
.LockAspectRatio = msoTrue
.Width = destRange.Width
.height = destRange.height '222
End With
End If
I am using below vba code to get images in excel sheet but this code add images in sheet as link, so when i am sending sheet to another pc that person get image location not found error.
How can i add attach images in sheet instead of link of image???
Sub AddOlEObject()
Dim mainWorkBook As Workbook
Set mainWorkBook = ActiveWorkbook
Sheets("Object").Activate
Folderpath = "C:\phoenix"
Set fso = CreateObject("Scripting.FileSystemObject")
NoOfFiles = fso.GetFolder(Folderpath).Files.Count
Set listfiles = fso.GetFolder(Folderpath).Files
For Each fls In listfiles
strCompFilePath = Folderpath & "\" & Trim(fls.name)
If strCompFilePath <> "" Then
If (InStr(1, strCompFilePath, ".jpg", vbTextCompare) > 1) Then
counter = counter + 1
Sheets("Object").Range("A" & counter).Value = fls.name
Sheets("Object").Range("B" & counter).ColumnWidth = 50
Sheets("Object").Range("B" & counter).RowHeight = 150
Sheets("Object").Range("B" & counter).Activate
Call insert(strCompFilePath, counter)
Sheets("Object").Activate
End If
End If
Next
End Sub
Function insert(PicPath, counter)
'MsgBox PicPath
With ActiveSheet.Pictures.insert(PicPath)
With .ShapeRange
.LockAspectRatio = msoTrue
.Width = 100
.Height = 150
End With
.Left = ActiveSheet.Range("B" & counter).Left
.Top = ActiveSheet.Range("B" & counter).Top
.Placement = 1
.PrintObject = True
End With
End Function
Is the Image a single image that you have saved in a personal directory that you use frequently? Also is the image saved as .JPEG?
why don't you use a simple VBA code below?
Sub CALLPICTURE()
Worksheets("SHEET1").Shapes.AddPicture Filename:="I:\Control\DECOMP\ Images\Zebra.jpg", linktofile:=msoFalse, _
savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=632, Height:=136
End Sub
You could add as many images as you want to.
I am exporting an excel table into word using VBA. The word document has one bookmark. The code is such that first it writes the TYPE as the heading and then write all the description under that TYPE. I want the headings to be bold and formatted. I have the following code but it does not work. If anyone could suggest something.
If Dir(strPath & "\" & strFileName) <> "" Then
'Word Document open
On Error Resume Next
Set objWDApp = GetObject(, "Word.Application")
If objWDApp Is Nothing Then Set objWDApp = CreateObject("Word.Application")
With objWDApp
.Visible = True 'Or True, if Word is to be indicated
.Documents.Open (strPath & "\" & strFileName)
Set objRng = objWDApp.ActiveDocument.Bookmarks("Bookmark").Range
.Styles.Add ("Heading")
.Styles.Add ("Text")
With .Styles("Heading").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = True
End With
With .Styles("Text").Font
.Name = "Arial"
.Size = 10
.Bold = False
.Underline = False
End With
End With
On Error GoTo 0
i = Start_Cell
idx(1) = i
n = 2
Do ' Search for first empty cell in the table
i = i + 1
If i > Start_Cell + 1 And Cells(i, QB_Type).Value = Cells(i - 1, QB_Type) Then GoTo Loop1
idx(n) = i
n = n + 1
Loop1:
Loop Until IsEmpty(Cells(i + 1, QB_Type).Value)
idxEnd = i
idx(n) = 9999
i = Start_Cell
n = 1
Do
If i = idx(n) Then
strTMP = vbNewLine & vbNewLine & Cells(idx(n), QB_Type).Value & vbNewLine
With objWDApp
'.Selection.Font.Bold = True 'Type Bold (Doesnt Functions!?)
.Selection.Styles ("Heading") 'I tried this as well but not functioning...gives an error here that object does not support this property
WriteToWord objRng, strTMP 'Text written
End With
n = n + 1
End If
strTMP = vbNewLine & Cells(i, QB_Description).Value & vbNewLine
With objWDApp
' .Selection.Font.Bold = False 'Description Not bold (Not functioning!?)
.Selection.Styles("Text") 'This is also not functioning
WriteToWord objRng, strTMP 'Text written
End With
i = i + 1 'Arbeitspunktzähler erhöhen
Loop Until i > idxEnd
Public Sub WriteToWord(objRng, text)
With objRng
.InsertAfter text
End With
End Sub
Try .Selection.Style.Name = "Heading" from here
Edit 2
The following code works as expected. You will need to modify it to fit your needs. I successfully added and then bolded text to an existing word document.
Option Explicit
Public Sub Test()
' Add a reference to Microsoft Word x.0 Object Library for early binding and syntax support
Dim w As Word.Application
If (w Is Nothing) Then Set w = New Word.Application
Dim item As Word.Document, doc As Word.Document
' If the document is already open, just get a reference to it
For Each item In w.Documents
If (item.FullName = "C:\Path\To\Test.docx") Then
Set doc = item
Exit For
End If
Next
' Else, open the document
If (doc Is Nothing) Then Set doc = w.Documents.Open("C:\Path\To\Test.docx")
' Force change Word's default read-only/protected view
doc.ActiveWindow.View = wdNormalView
' Delete the preexisting style to avoid an error of duplicate entry next time this is run
' Could also check if the style exists by iterating through all styles. Whichever method works for you
doc.Styles.item("MyStyle").Delete
doc.Styles.Add "MyStyle"
With doc.Styles("MyStyle").Font
.Name = "Arial"
.Size = 12
.Bold = True
.Underline = wdUnderlineSingle
End With
' Do your logic to put text where you need it
doc.Range.InsertAfter "This is another Heading"
' Now find that same text you just added to the document, and bold it.
With doc.Content.Find
.Text = "This is another Heading"
.Execute
If (.Found) Then .Parent.Bold = True
End With
' Make sure to dispose of the objects. This can cause issues when the macro gets out mid way, causing a file lock on the document
doc.Close
Set doc = Nothing
w.Quit
Set w = Nothing
End Sub
By adding a reference to the object library, you can get intellisense support and compilation errors. It would help you determine earlier in development that Styles is not a valid property off the Word.Application object.
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