I have created a template on excel which is populated with data for a specific country. The template contains 3 tables and a chart (line graph). I have a list of countries that I need to loop through, and for each loop, I need to create a powerpoint slide made up of the 3 tables and chart.
I build the macro below using bits from various sources (mostly from this platform). The macros scales and positions each of the elements. The first slide populates correctly, but I am running into the following issues:
All the tables and charts are positioned correctly on the first slide, but are not being positioned on every other slide. Note that the objects are still being scaled correctly
I get Run-time error ‘-214788160 (80048240): Selection (unknown member) : Invalid request. This view does not support selection
Does anyone have any suggestions for what the issue could be?
Sub MulipleCountrySlides()
'Step 1: Declare your variables
Dim ListOfSystems As Variant
Dim pptLayout As CustomLayout
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlides As PowerPoint.Slides
Dim PPSlide As PowerPoint.Slide
Dim SlideTitle As String
Dim XLS_Out As Variant
Dim shp As Object
Dim chtObj As ChartObject
Dim chtTop As Double
Dim chtLeft As Double
Dim chtWidth As Double
Dim chtHeight As Double
'Step 2: Open PowerPoint and create new presentation
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
'Step 3: Add new slide as slide 1 and set focus to it
PPPres.ApplyTemplate "C:\Users\yogeswaran saravanan\AppData\Roaming\Microsoft\Templates\blank.potx"
ListOfSystems = Range("listofsystemstest") 'This is the list of systems that I will be looping through
For y = LBound(ListOfSystems) To UBound(ListOfSystems)
Set PPSlide = PPPres.Slides.Add(y, ppLayoutTitleOnly)
Worksheets("System output sheet").Range("j2").Value = ListOfSystems(y, 1)
Sheets("Indexed data").Calculate
ActiveSheet.Calculate
If Not Application.CalculationState = xlDone Then ' Calculation takes a while to run
DoEvents
End If
Set PPSlide = PPPres.Slides(y)
'The following arrays specify the regions/charts to be copied/pasted,
'the sizes/positions of these regions/charts, and the slide numbers corresponding
'to region/chart destinations
'Region/chart widths (Length/width ratios are preserved)
OWidth = Array(910, 450, 900, 465) '' 72px per Inch
OHeight = Array(400, 120, 33, 147)
'Horizontal positions on slides
OLeft = Array(22, 22, 22, 22)
'Vertical positions on slides
OTop = Array(100, 360, 504, 200)
'Regions and charts to be copied/pasted
XLS_Out = Array(Range("Countryslidetable"), _
Range("Chartdeltas"), _
Range("Countryfootnote"), _
Worksheets("System output sheet").ChartObjects("Chart 1"))
'Region/Chart type: 1 corresponds to chart objects, 0 corresponds to regions
XLS_OutFormat = Array(0, 0, 0, 1)
'Loop through arrays and copy/paste regions and charts one at a time
For x = 0 To 3 'LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel range/chart
XLS_Out(x).Copy
'Paste to PowerPoint
If (XLS_OutFormat(x) = 0) Then
'Paste an Excel range
Set shp = PPPres.Slides(y).Shapes.PasteSpecial(ppPasteHTML)
Else
'Paste an Excel chart
Set shp = PPPres.Slides(y).Shapes.PasteSpecial(ppPasteShape)
shp.LinkFormat.BreakLink
End If
'Change position/size of pasted regions/charts based on previously-defined arrays
With PPPres.Slides(y)
'shp.LockAspectRatio = msoTrue
shp.Height = OHeight(x)
shp.Width = OWidth(x)
shp.Top = OTop(x)
shp.Left = OLeft(x)
shp.ZOrder msoSendToFront
'End With
If (XLS_OutFormat(x) = 0) Then
If (x = 2) Then
PP.ActiveWindow.Selection.ShapeRange.TextEffect.FontSize = 10
End If
If (x = 0) Then
'Set oShp = PPSlide.Shapes(1)
'Set oShp = PP.ActiveWindow.Selection.ShapeRange
Set oTbl = shp.Table
For i = 1 To oTbl.Columns.Count
For J = 1 To oTbl.Rows.Count
'oShp.TextFrame.TextRange.Font.Size = 11
oTbl.Cell(J, i).Shape.TextFrame.TextRange.Font.Size = 11
Next
Next
End If
End If
End With
Next x
'Step 6: Add the title to the slide
SlideTitle = "Country Price Recommendations: " & Worksheets("System output sheet").Range("J2")
PPPres.Slides(y).Shapes.Title.TextFrame.TextRange.Text = SlideTitle
'Step 7: Memory Cleanup
PP.Activate
Next y
Set PPSlide = Nothing
Set PPPres = Nothing
Set PP = Nothing
End Sub
Related
(Post updated with entire code, sorry about the beginner mistake)
Newbie to both coding and VBA here and I'm trying to adjust the PlotArea for a Chart in a presentation. I'm running this from Excel.
Creating and populating the Chart goes fine, sizing ChartArea is also no problems and formating all titles etc is also without problems.
When the Chart looks athe way I want it to, is the correct size and at the correct place, I want the PlotArea to be a precise size and in a precise location. Sizing goes well but the position does not work.
Here is the code that I use, Including populating the ChartData with dummy data and adding in a red box to show where I want the PlotArea to sit:
Sub CreateChart()
'Declare Excel Object Variables
Dim pptWorkBook As Excel.Workbook
Dim pptWorkSheet As Excel.Worksheet
'Declare PowerPoint Object Variables
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.Slide
Dim PPTShape As PowerPoint.Shape
Dim PPTChart As PowerPoint.Chart
Dim PPTChartData As PowerPoint.ChartData
Dim SldHeight, SldWidth As Integer
Dim ChrHeight, ChrWidth As Single
Dim PlotHeight, PlotWidth As Double
'Declare Excel Object Variable
Dim ExcRange As Range
'Create a new instance of Powerpoint
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
'Create a new Presentation within the Application
Set PPTPres = PPTApp.Presentations.Add
'Disable Snap-To-Grid
PPTPres.SnapToGrid = msoFalse
'Create a new slide within the Presentation
Set PPTSlide = PPTPres.Slides.Add(1, ppLayoutBlank)
'Find out size (points) of Slide
SldHeight = PPTPres.PageSetup.SlideHeight
SldWidth = PPTPres.PageSetup.SlideWidth
'Calculate Chart and Plot Size
ChrWidth = 954
ChrHeight = 525 - 106
PlotWidth = 866 - 95
PlotHeight = 437 - 106 - 20
'No screen updates
Application.ScreenUpdating = False
'Create a new Chart within the Slide, give it proper size
Set PPTShape = PPTSlide.Shapes.AddChart2(-1, xlColumnClustered, 0, 106, ChrWidth, ChrHeight, True)
'Minimize ChartData
PPTShape.Chart.ChartData.Workbook.Application.WindowState = -4140
'Set chartdata
Set PPTChartData = PPTShape.Chart.ChartData
'Set Workbook object reference
Set pptWorkBook = PPTChartData.Workbook
'Set Worksheet object reference
Set pptWorkSheet = pptWorkBook.Worksheets(1)
'Add Data
pptWorkSheet.ListObjects("Table1").Resize pptWorkSheet.Range("A1:B5")
pptWorkSheet.Range("b1").Value = "Items"
pptWorkSheet.Range("a2").Value = "Bikes"
pptWorkSheet.Range("a3").Value = "Accessories"
pptWorkSheet.Range("a4").Value = "Repairs"
pptWorkSheet.Range("a5").Value = "Clothing"
pptWorkSheet.Range("b2").Value = "1000"
pptWorkSheet.Range("b3").Value = "2500"
pptWorkSheet.Range("b4").Value = "4000"
pptWorkSheet.Range("b5").Value = "3000"
'Apply Style
With PPTShape.Chart
.ChartStyle = 4
End With
'Remove title
With PPTShape.Chart
.HasTitle = False
End With
'Format legend
With PPTShape.Chart
.HasLegend = True
.Legend.Position = xlLegendPositionTop
.Legend.Top = 0
End With
'Add axis title
With PPTShape.Chart.Axes(xlValue)
.HasTitle = True
.AxisTitle.Text = "Dollars"
End With
'Remove gridlines
With PPTShape.Chart.Axes(xlValue)
.HasMajorGridlines = False
.HasMinorGridlines = False
End With
'Add data labels
PPTShape.Chart.ApplyDataLabels
'Set PlotArea position and size
With PPTShape.Chart.PlotArea
.InsideLeft = 95
.InsideTop = 20
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
End With
'Adding a red textbox with the same dimensions and position as the PlotArea
With PPTShape.Chart.Shapes.AddTextbox(msoTextOrientationDownward, 95, 20, PlotWidth, PlotHeight)
.Line.Weight = 2
.Line.DashStyle = msoLineLongDash
.Line.ForeColor.RGB = RGB(255, 0, 0)
End With
'Quit
Set pptWorkSheet = Nothing
pptWorkBook.Application.Quit
Set pptWorkBook = Nothing
Set PPTChartData = Nothing
Set PPTChart = Nothing
'Screen updates
Application.ScreenUpdating = True
End Sub
Below you can see the result with dummy data. The red box is correct, the PlotArea is the right size but not in the right position. Am I misunderstanding something regarding the InsideLeft vs Left properties? I've been stuck here for hours now and I am not making any progress. A theory a colleague and I have is that the PlotArea is doing a Snap-To to something that can't be seen.
Any help is appreciated!
UPDATE:
I changed the order of positioning and sizing of the PlotArea and it improved.
'Set PlotArea position and size
With PPTShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.InsideLeft = 95
.InsideTop = 20
End With
The offset from the red box seems consistent and I'm sure it is a small thing I am missing somewhere. See attached image of the new result below.
UPDATE 2:
Here is how I solved this. I'm not entirely sure it is correct logic, but it works at least.
I need to offset the PlotArea by 3.9 points. This seems to involve spacing for TickMarks. My assumption here is that the PlotArea position (.InsideTop and .InsideLeft etc) include TickMark width and height but lacks the means to adjust for this. My workaround looks like this:
'Set the TickMark offset constant
offSet = 3.9
'Set PlotArea position and size
With theShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.InsideLeft = 95 - offSet
.InsideTop = 20 - offSet
End With
As this is mostly guesswork, as far as a solution is concerned, any real answers and not workarounds would still be appreciated.
It seems you're trying to position the chart, not the plot area. Try something like this instead:
'Set PlotArea size and position
With PPTShape.Chart.PlotArea
.InsideWidth = PlotWidth
.InsideHeight = PlotHeight
.Left = 60
.Top = -25
End With
Ive made a VBA macro that automatically creates a PowerPoint and one that creates a Worksheet named "Handlungsempfehlungen" with Text. The Worksheet "Handlungsempfehlungen" looks like this:
https://i.stack.imgur.com/nZEL8.png
It has about 40 columns (A-AO) and Text in each column from Row 1 to max. 34 (Number of rows filled with text varies each column). I now need to somehow loop through each row in each column and give each Cell.Value over to the existing (and currently opened) PowerPoint. Until now Ive used something like this to create textboxes in PowerPoint and fill them with Cell Values from Excel:
'New PPslide (copy slide 2 which is emtpy)
Set PPslide = PPapp.ActivePresentation.Slides(2).Duplicate.Item(1)
'Put new slide to end of PP
PPslide.MoveTo (PPpres.Slides.Count)
'Change title
PPslide.Shapes.Title.TextFrame.TextRange = "Slidetitle"
PPslide.Shapes(2).TextFrame.TextRange.Text = "Second title"
'Insert Textbox
Set PPtextbox = PPslide.Shapes.AddTextbox(msoTextOrientationHorizontal, Left:=40, Top:=133, Width:=875, Height:=30)
PPtextbox.TextFrame.TextRange.Text = ActiveWorkbook.Worksheets("Handlungsempfehlungen").Cells(1, 1).Value
But with 40 columns and about 30 rows per column each filled with text I would need to create about 1000 textboxes and hand them to my PowerPoint. How could I loop through this Worksheet and automatically have positions on the PowerPoint Slide set for each textbox? The slidetitle for each PowerPointslide is already saved in the Row 35 of each Column in the Worksheet (see screenshot), so I would give this over to PP inside the loop as well (for each column set slidetitle = currentColumn.Row 35 is kinda the idea)
My current Idea for all of this is I having 5 textboxes per slide with set positions, filling them with the values from row 1-5 of the first column and then create a new slide and do the same process for rows 6-10 and so on until the Cell.Value in the current column is empty, then jump one column to the right and create a new PPslide again and repeat the whole process until the whole Worksheet has been worked through. I think this seems relatively simple but I am still a beginner and have difficulties implementing this.
Would this be a good idea and how would I need to get there? Im quite bad at looping but Im happy for every answer! Thanks for your time & help!
PS: the declarations for the created PP and its Objects:
Public Shape As Object
Public PPshape As PowerPoint.Shape
Public PPapp As PowerPoint.Application
Public PPpres As PowerPoint.Presentation
Public PPslide As PowerPoint.Slide
Public PPtextbox As PowerPoint.Shape
Set PPapp = New PowerPoint.Application
PPapp.Visible = msoTrue
The following code covers two scenarios:
You have PowerPoint open with an active presentation that has a slide at the begining with a Title and 5 texboxes properly named
You have PowerPoint closed
You need to set a reference to PowerPoint object model like this:
Read code's comments and try to adjust it to fit your needs
Use the F8 key to step into the code line by line
You can also add a Stop statement so the code breaks and then use the F8 key
Public Sub TransferDataToPPT()
' Set basic error handling
On Error GoTo CleanFail
' Turn off stuff
Application.ScreenUpdating = False
Dim pptApp As PowerPoint.Application
Dim pptPresentation As PowerPoint.Presentation
Dim pptMainSlide As PowerPoint.Slide
Dim pptContentSlide As PowerPoint.Slide
Dim isNewPPTInstance As Boolean
' Open and get PowerPoint instance
Set pptApp = OpenGetPowerPoint(isNewPPTInstance)
' If it's a new instance add new presentation and main slide
If isNewPPTInstance Then
pptApp.Visible = msoTrue
Set pptPresentation = pptApp.Presentations.Add(msoTrue)
Set pptMainSlide = pptPresentation.Slides.Add(1, ppLayoutTitleOnly)
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 150, 100, 20).Name = "Textbox1"
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 200, 100, 20).Name = "Textbox2"
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 250, 100, 20).Name = "Textbox3"
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 300, 100, 20).Name = "Textbox4"
pptMainSlide.Shapes.AddTextbox(msoTextOrientationHorizontal, 100, 350, 100, 20).Name = "Textbox5"
Else
Set pptPresentation = pptApp.ActivePresentation
Set pptMainSlide = pptPresentation.Slides(1)
End If
' Set a reference to the sheet holding the values
Dim contentSheet As Worksheet
Set contentSheet = ThisWorkbook.Worksheets("Sheet1")
' Set the Excel range to be evaluated
Dim contentRange As Range
Set contentRange = contentSheet.Range("A1:AO34")
' Start a cell counter
Dim cellCounter As Long
cellCounter = 1
' Loop through columns and cells
Dim contentColumn As Range
Dim contentCell As Range
For Each contentColumn In contentRange.Columns
For Each contentCell In contentColumn.Cells
' Skip after first blank cell
If contentCell.Value = vbNullString Then Exit For
' Add new slide every 5 cells and fill title
If cellCounter = 1 Then
Set pptContentSlide = pptPresentation.Slides(1).Duplicate()(1)
pptContentSlide.MoveTo pptPresentation.Slides.Count
pptContentSlide.Shapes.Title.TextFrame.TextRange = contentSheet.Cells(35, contentColumn.Column).Value
End If
' Add value to textbox
pptContentSlide.Shapes("Textbox" & cellCounter).TextFrame.TextRange = contentCell.Value
cellCounter = cellCounter + 1
' Reset counter
If cellCounter > 5 Then cellCounter = 1
Next contentCell
Next contentColumn
CleanExit:
' Turn on stuff again
Application.ScreenUpdating = True
If isNewPPTInstance Then
If Not pptApp Is Nothing Then
pptPresentation.SaveAs "C:\Temp\NewPPT.pptx"
pptApp.Quit
End If
End If
Set pptApp = Nothing
Exit Sub
CleanFail:
MsgBox "An error occurred:" & Err.Description
GoTo CleanExit
End Sub
Private Function OpenGetPowerPoint(ByRef isNewPPTInstance As Boolean) As PowerPoint.Application
Dim pptApp As PowerPoint.Application
On Error Resume Next
Set pptApp = GetObject(, "PowerPoint.Application")
If pptApp Is Nothing Then
'PPT wasn't running, start it from code:
Set pptApp = CreateObject("PowerPoint.Application")
isNewPPTInstance = True
End If
Set OpenGetPowerPoint = pptApp
End Function
Let me know if it works
I have excel with data that I'm writing in word, it is open and I try to copy chart from excel to word, without linking it, so that any other user can open it without static link to original excel file.
Sub Make4Segment(Wapp As Object)
Dim Sheet As Excel.Worksheet
Dim MyChart As ChartObject
Set Sheet = Excel.ThisWorkbook.Sheets("DOC")
Set MyChart = Excel.ThisWorkbook.Sheets("DOC").ChartObjects("C1")
MyChart.Chart.ChartArea.Copy
With Wapp.Application.Selection.Range
.PasteAndFormat Type:=wdChart
End With
End sub
I'm getting error 4605 on paste line.
Change:
.PasteAndFormat Type:=wdChart
With:
.PasteSpecial Link:=False, DataType:=26
That should paste the Object correctly with Data and Without Link
You can Try with these different datatypes if this one is not what you need.
To reader in future: I was unable to find easy copy/paste solution to copy chart form excel to word. So I created this monstrosity. It creates chart in word, copies data for chart form excel file and embeds data in word file. Loads chart settings from excel files cells for ease of changing chart appearance. Resulting word document is independent and with chart data, and can be sent to anyone.
Sub GenerateReport()
Dim Wapp As Object
'Launches word application
Set Wapp = CreateObject("Word.Application")
Wapp.Visible = True
Wapp.Activate
...
Call CreateChart(Wapp)
End Sub
'Procedure, that creates chart in Word
Sub CreateChart(Wapp As Object)
Dim Ch4y As Word.InlineShape
Dim EmChData As Excel.Worksheet
Dim SrDataSh As Excel.Worksheet
Dim FomtCh As Excel.ChartObject
Dim DbWidth As Double
Dim DbHeight As Double
Dim DbIndentCh As Double
Dim DbLineWeight As Double
Dim DbDegrees As Double
Dim DbChLeHeight As Double
Dim DbChLeWidth As Double
Dim DbChLeLeft As Double
Dim DbChLeTop As Double
Dim LnChType As Long
Dim LnXLabelSpace As Long
Dim LnYMayorUnit As Long
Dim LnYMinimumScale As Long
Dim LnChBorder As Long
Dim LnChFontSize As Long
Dim BoLegend As Boolean
Dim BoTitle As Boolean
Dim In1 As Integer
Dim In2 As Integer
Dim In3 As Integer
Dim In4 As Integer
Dim In5 As Integer
Dim In6 As Integer
Dim In7 As Integer
Dim In8 As Integer
Dim In9 As Integer
Dim StChFont As String
'Creates new chart in word
Set Ch4y = Wapp.ActiveDocument.InlineShapes.AddChart2
'Embed data in chart, to make it independent form excel
'Creates reference to place where data will be stored
Set EmChData = Ch4y.Chart.ChartData.Workbook.Worksheets(1)
'Creates reference to source data sheet
Set SrDataSh = Excel.ThisWorkbook.Sheets("DOC")
'Loads data from Excel sheet for customizability
DbWidth = SrDataSh.Range("A159").Value '490
DbHeight = SrDataSh.Range("A160").Value '180
DbIndentCh = SrDataSh.Range("A161").Value '0
LnChType = SrDataSh.Range("A162").Value '4
BoLegend = SrDataSh.Range("A163").Value 'True
BoTitle = SrDataSh.Range("A164").Value 'False
In1 = SrDataSh.Range("A166").Value '139
In2 = SrDataSh.Range("A167").Value '231
In3 = SrDataSh.Range("A168").Value '246
In4 = SrDataSh.Range("A170").Value '0
In5 = SrDataSh.Range("A171").Value '133
In6 = SrDataSh.Range("A172").Value '155
DbLineWeight = SrDataSh.Range("A173").Value '1.75
DbDegrees = SrDataSh.Range("A174").Value '90
LnXLabelSpace = SrDataSh.Range("A175").Value '1
LnYMayorUnit = SrDataSh.Range("A176").Value '10
LnYMinimumScale = SrDataSh.Range("A177").Value '70
LnChBorder = SrDataSh.Range("A178").Value '-4142
StChFont = SrDataSh.Range("A179").Value 'Open Sans
LnChFontSize = SrDataSh.Range("A180").Value '9
In7 = SrDataSh.Range("A182").Value '151
In8 = SrDataSh.Range("A183").Value '151
In9 = SrDataSh.Range("A184").Value '151
DbChLeHeight = SrDataSh.Range("A185").Value '18
DbChLeWidth = SrDataSh.Range("A186").Value '200
DbChLeLeft = SrDataSh.Range("A187").Value '140
DbChLeTop = SrDataSh.Range("A188").Value '155
'Clears range
EmChData.Range("A1:XFD1048576").Clear
'Copy data
EmChData.Range("A1:C49").Value = SrDataSh.Range("B109:D157").Value
'Set Source data
Ch4y.Chart.SetSourceData Source:="'Sheet1'!$A$1:$C$49", PlotBy:=xlColumns
'Create reference to excel chart
Set FomtCh = ThisWorkbook.Sheets("Doc").ChartObjects(1)
With Wapp
With .Selection
'This line change position of chart that will be created to left or to right
.ParagraphFormat.LeftIndent = DbIndentCh
End With
End With
'Creates needed formating
With Ch4y
'Set size for chart
.Width = DbWidth
.Height = DbHeight
With .Chart
'Sets chart type
.ChartType = LnChType
'Sets chart legend to visible/unvisable
.HasLegend = BoLegend
'Sets chart title visible/unvisable
.HasTitle = BoTitle
'Sets color back to original for data series lines (for some reason it is not pasted in previous line)
.SeriesCollection(1).Format.Line.ForeColor.RGB = RGB(In1, In2, In3)
.SeriesCollection(2).Format.Line.ForeColor.RGB = RGB(In4, In5, In6)
'Sets line thicknes
.SeriesCollection(1).Format.Line.Weight = DbLineWeight
.SeriesCollection(2).Format.Line.Weight = DbLineWeight
'Works with x-axis
With .Axes(xlCategory)
'Sets orientation of x axis labels
.TickLabels.Orientation = DbDegrees
'Force to show all month under x-axis
.TickLabelSpacing = LnXLabelSpace
End With
'Works with y-axis
With .Axes(xlValue)
'Sets unit size for y-axis
.MajorUnit = LnYMayorUnit
'Sets value on y-axis from where values will start (Changes y=0 to value specified)
.MinimumScale = LnYMinimumScale
End With
With .ChartArea
'Sets border to none
.Border.LineStyle = LnChBorder
'Sets font
.Format.TextFrame2.TextRange.Font.Name = StChFont
'Sets font size
.Format.TextFrame2.TextRange.Font.Size = LnChFontSize
'Sets chart font color
.Font.Color = RGB(In7, In8, In9)
End With
'Checks if Legend for chart is enabled
If .HasLegend = True Then
With .Legend
'Sets height of legend
.Height = DbChLeHeight
'Sets width of legend
.Width = DbChLeWidth
'Sets distance from left side of chart
.Left = DbChLeLeft
'Sets distance from top side of chart
.Top = DbChLeTop
End With
End If
End With
End With
End Sub
I am pasting some excel data into powerpoint as a picture and I am having some issues. I have 290 files which I am pasting a table into slide 4, 5 and 6 of each PP file. This worked perfectly yesterday when I was only doing 1 table into slide 6. I have replicated the process and now I keep getting random errors at random times. Sometimes its file 10, others file 50, different everytime. The errors range from the paste datatype is not available OR the clipboard is empty. I have tried every datatype, pasting as a metafile, as a shape, as a picture, just basic pasting and nothing stops the error. I have no idea! Here is my code: PLEASE HELP !
Sub Update_Site_Report()
'Initiate Variables
Dim objPPT As Object
Dim PPTPrez As Object
Dim FinSlide As Object
Dim AssumSlide As Object
Dim RiskSlide As Object
Dim FinTable As Object
Dim AssumTable As Object
Dim RiskTable As Object
Dim fileNameString As String
Dim PicCount As Long
Dim PicCount1 As Long
Dim PicCount2 As Long
Dim i As Long
Dim fileN As String
Dim Directory As String
'Create and open powerpoint application
Set objPPT = CreateObject("PowerPoint.Application")
objPPT.Visible = True
Application.ScreenUpdating = False
'Update site report table from spreadsheet
For i = 2 To 291
Sheet20.Cells(18, 2) = Sheet20.Cells(5, i)
Sheet20.Cells(19, 2) = Sheet20.Cells(6, i)
Sheet20.Cells(20, 2) = Sheet20.Cells(7, i)
Sheet20.Cells(21, 2) = Sheet20.Cells(8, i)
Sheet20.Cells(18, 3) = Sheet20.Cells(10, i)
Sheet20.Cells(19, 3) = Sheet20.Cells(11, i)
Sheet20.Cells(20, 3) = Sheet20.Cells(12, i)
Sheet20.Cells(21, 3) = Sheet20.Cells(13, i)
'Take column header from spreadsheet and set as filename
fileN = Sheet20.Cells(4, i)
' Allow directory to be set in excel tab
Directory = Sheet20.Cells(18, 5)
'Open powerpoint presentation at Directory with Filename
Set PPTPrez = objPPT.Presentations.Open(Directory & fileN & ".pptx")
'Set range for site report table
Set Financials = Sheet20.Range("A17:C21")
Set Assumptions = Sheet45.Range("A1:C7")
Set Risks = Sheet45.Range("A24:D41")
'Choose which slide to paste site report table
Set FinSlide = PPTPrez.Slides(6)
Set AssumSlide = PPTPrez.Slides(4)
Set RiskSlide = PPTPrez.Slides(5)
'If there is a table in powerpoint slide, delete the table
For PicCount1 = AssumSlide.Shapes.Count To 1 Step -1
If AssumSlide.Shapes(PicCount1).Type = msoPicture Then
AssumSlide.Shapes(PicCount1).Delete
End If
Next
For PicCount = FinSlide.Shapes.Count To 1 Step -1
If FinSlide.Shapes(PicCount).Type = msoPicture Then
FinSlide.Shapes(PicCount).Delete
End If
Next
For PicCount2 = RiskSlide.Shapes.Count To 1 Step -1
If RiskSlide.Shapes(PicCount2).Type = msoPicture Then
RiskSlide.Shapes(PicCount2).Delete
Debug.Print
End If
Next
'Paste the site report table into the site report
Financials.Copy
FinSlide.Shapes.PasteSpecial ppPasteShape
Set FinTable = FinSlide.Shapes(FinSlide.Shapes.Count)
Assumptions.Copy
AssumSlide.Shapes.PasteSpecial ppPasteShape
Set AssumTable = AssumSlide.Shapes(AssumSlide.Shapes.Count)
Risks.Copy
RiskSlide.Shapes.PasteSpecial ppPasteShape
Set RiskTable = RiskSlide.Shapes(RiskSlide.Shapes.Count)
'Set position of site report table in powerpoint
FinTable.Left = 36
FinTable.Top = 175
FinTable.Width = 614
AssumTable.Left = 36
AssumTable.Top = 80.8
RiskTable.Left = 36
RiskTable.Top = 80.8
RiskTable.Width = 641.5
'Set filename as string
fileNameString = Directory & fileN & ".pptx"
'Save file as filename
PPTPrez.SaveAs fileNameString
'Close powerpoint presentation
PPTPrez.Close
'Repeat for every site (column) - increment i
Next i
'quit powerpoint
objPPT.Quit
Application.ScreenUpdating = True
MsgBox ("Update complete, click ok to exit powerpoint")
End Sub
Disabling Windows clipboard history solves this issue.
Berry is a Range of multiple cells from another excel file and Melon is a table in a powerpoint slide. I am attempting to paste Berry into the ppt table, by first selecting the cell(3,2) on the ppt table. After doing so, I would like to unselect anything. and select cell(3.7).
The following code successfully pastes the range into the table with Cell(3,2) in the top left corner.
Berry.Copy
Melon.Table.Cell(3, 2).Shape.Select
Lemon.CommandBars.ExecuteMso ("PasteExcelTableDestinationTableStyle")
However, when i try the following code, the range gets pasted into the table with Cell(3,7) in the top left corner. I would think the range will get pasted as per earlier followed by merely have the Cell(3,7) selected without any pasting.
Berry.Copy
Melon.Table.Cell(3, 2).Shape.Select
Lemon.CommandBars.ExecuteMso ("PasteExcelTableDestinationTableStyle")
Melon.Table.Cell(3, 7).Shape.Select
It seems like the ExecuteMso code always get executed as the last line of code.
Pardon my english and I thank you for your time and help.
The following is the complete code:
Sub Auto()
Application.CutCopyMode = False
Dim apple As Workbook
Dim grape As Workbook
Dim orange As Range
Dim Kiwi As Shape 'Shape
Dim Peach As Object
Dim Berry As Range
Dim pear As Range
Dim Lemon As PowerPoint.Application 'PPApp
Dim LemonJuice As PowerPoint.Presentation 'PPpres
Dim Melon As PowerPoint.Shape
Dim LCounter As Integer
Set grape = Workbooks.Open(Filename:="C:\Users\206521654\Documents\Automate vba\try.xlsx")
Set apple = Workbooks.Open(Filename:="C:\Users\206521654\Documents\Automate vba\Monthly Report\Msia\Weekly Channel Ranking Broken Out.xlsx")
Set orange = apple.Sheets("Periods").Range("A5:C25")
orange.Copy
grape.Sheets("Sheet1").Range("B3:D23").PasteSpecial xlPasteValues
grape.Sheets("Sheet1").Range("E3").Formula = "=D3/C3-1"
Set SourceRange = grape.Sheets("Sheet1").Range("E3")
Set fillRange = grape.Sheets("Sheet1").Range("E3:E23")
SourceRange.AutoFill Destination:=fillRange
grape.Sheets("Sheet1").Range("E3:E23").NumberFormat = "0%"
grape.Sheets("Sheet1").Range("B3:E23").Font.Name = "Calibri"
grape.Sheets("Sheet1").Range("B3:E23").Font.Size = "11"
grape.Sheets("Sheet1").Range("C3:D23").NumberFormat = "0.000"
For Each Cell In grape.Sheets("Sheet1").Range("E3:E23")
If Cell.Value < 0 Then
Cell.Font.Color = vbRed
Else:
Cell.Font.Color = vbBlue
End If
Next
Set Berry = grape.Sheets("Sheet1").Range("B3:E23")
Berry.Copy
Set Lemon = New PowerPoint.Application
Set LemonJuice = Lemon.Presentations.Open("C:\Users\206521654\Documents\Automate vba\Automate test.pptx")
Set Melon = LemonJuice.Slides(1).Shapes(8)
Melon.Table.Cell(3, 2).Shape.Select
Lemon.CommandBars.ExecuteMso "PasteExcelTableDestinationTableStyle"
Melon.Table.Cell(7, 2).Shape.Select
End Sub
So here is some example code that takes an open excel document and open powerpoint and copies over the table data from excel into a NEW table in powerpoint.
You MUST add the powerpoint reference to your excel VBA.
Put something in cells 2,2 and 2,3 in excel, it should be pasted over into a new table in powerpoint.
Note: Since I merely mashed a bunch of code from the documentation together, you get some unnecessary functionality such as creating a new table every time and modifying all tables, but I hope that this code serves as a necessary base for showing you how you can avoid using msoExecute.
Option Explicit
Sub TestCopyData()
Dim sSht As Worksheet
Set sSht = ActiveWorkbook.Sheets("Sheet1")
Dim PPApp As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPSlide As PowerPoint.Slide
'Open PPT if not running, otherwise select active instance
On Error Resume Next
Set PPApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0
If PPApp Is Nothing Then
'Open PowerPoint
Set PPApp = CreateObject("PowerPoint.Application")
PPApp.Visible = True
End If
PPApp.ActivePresentation.Slides(1).Shapes _
.AddTable NumRows:=3, NumColumns:=4, Left:=10, _
Top:=10, Width:=288, Height:=288
Dim sh As Integer
Dim col As PowerPoint.Column
With PPApp.ActivePresentation.Slides(1)
For sh = 1 To .Shapes.Count
If .Shapes(sh).HasTable Then
For Each col In .Shapes(sh).Table.Columns
Dim cl As PowerPoint.Cell
For Each cl In .Shapes(sh).Table.Rows(2).Cells
cl.Shape.Fill.ForeColor.RGB = RGB(50, 125, 0)
Next cl
.Shapes(sh).Table.Columns(1).Width = 110
.Shapes(sh).Table.Cell(2, 1).Shape.TextFrame.TextRange.Text = sSht.Cells(2, 2)
.Shapes(sh).Table.Cell(2, 2).Shape.TextFrame.TextRange.Text = sSht.Cells(2, 3)
Next col
End If
Next
End With
End Sub