font size while copying excel range to powerpoint - vba

I am trying to copy a range from Excel to Powerpoint using VBA. Once I run the VBA macro. The range is pasted in powerpoint of font size =6. I want the font size to be 9 when pasted into powerpoint.
This is the code :
Sub ExcelRangeToPowerPoint()
Dim rng As Excel.Range
Dim PowerPointApp As PowerPoint.Application
Dim myPresentation As PowerPoint.Presentation
Dim mySlide As PowerPoint.Slide
Dim myShapeRange As PowerPoint.Shape
'Columns("M:M").Select
'Columns("M:M").EntireColumn.AutoFit
'Copy Range from Excel
Set rng = ThisWorkbook.ActiveSheet.Range("C8:M56")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(Class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(Class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, ppLayoutTitleOnly)
'Copy Excel Range
rng.Copy
'Paste to PowerPoint and position
mySlide.Shapes.Paste
'Special DataType:=ppPasteEnhancedMetafile
Set myShapeRange = mySlide.Shapes(mySlide.Shapes.Count)
myShapeRange.Left = 25
'myShapeRange.Top = 27
myShapeRange.Width = myPresentation.PageSetup.SlideWidth - 30
myShapeRange.Height = myPresentation.PageSetup.SlideHeight - 120
'Set position:
'PowerPointApp.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
'PowerPointApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoTrue
'Clear The Clipboard
Application.CutCopyMode = False
End Sub

Instead of copying the Excel range and pasting into PowerPoint (which will generate a native PowerPoint table), modify your original code to include the following. This will simultaneously populate your table in PowerPoint and change the font size.
Dim tblShape As PowerPoint.Shape
With mySlide.Shapes
Set tblShape = .AddTable(NumRows:=rng.Rows.Count, NumColumns:=rng.Columns.Count, Left:=30, _
Top:=110, Width:=660, Height:=320)
End With
Dim i As Long, j As Long, k As Long, l As Long
k = 1 ' PowerPoint Table row
For i = rng.Row To rng.Row + rng.Rows.Count - 1
l = 1 'PowerPoint Table column
For j = rng.Column To rng.Column + rng.Columns.Count - 1
tblShape.Table.Cell(k, l).Shape.TextFrame.TextRange.Text = ThisWorkbook.ActiveSheet.Cells(i, j).Value
tblShape.Table.Cell(k, l).Shape.TextFrame.TextRange.Font.Size = 15
l = l + 1
Next j
k = k + 1
Next i

If you want to keep the source formatting just use paste special instead of paste so change mySlide.Shapes.Paste to mySlide.Shapes.PasteSpecial ppPasteOLEObject

Related

From a few Excel files to PowerPoint

I'm totally new in VBA programming. However I have to (and want) create macro in Excel file to automatically creating PowerPoint presentation.
I hope that someone will be able to help me or have a similar problem.
Namely - I have 6 columns in the Excel file:
1 - slide number
2 - file access path
3 - file name
4 - sheet name
5 - slide range
6 - slide title
I would like the macro to automatically enter a given file -> sheet -> take the slide's range, copy and paste it as a picture for the presentation and give it the appropriate title and go through the loop to the next line and do the same.
Is anyone able to help me? Below is the code that I managed to write, however, I do not know how to refer to the sheet and the range of the slide from the given cell.
Option Explicit
Sub ExcelRangeToPowerPoint()
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim adr1 As String
Dim shta As Worksheet
Dim wrk As String
Application.DisplayAlerts = False
wrk = ThisWorkbook.Name ' nname
adr1 = Worksheets("Sheet1").Range("B2")
'Copy Range from Excel
' Set rng = ThisWorkbook.ActiveSheet.Range("A1:C12")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
ThisWorkbook.Activate
Range("A2").Select
'DO While
Do While ActiveCell.Value <> ""
Workbooks.Open Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True ' to be sure read-only open
' Worksheet Open from D2
'Copy Range from E2
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile + title from F2
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
ActiveWorkbook.Close SaveChanges:=False ' close file and don't save
ActiveCell.Offset(1, 0).Range("A1").Select
Loop
MsgBox ("Ready")
Application.CutCopyMode = False
Application.DisplayAlerts = True
End Sub
You can always refer to some sheet or Workbook creating first variables type Workbook or Worksheets.
If you want to refer a variable to a worksheet/workbook, is pretty easy. Is just a set. Something like:
Dim wb as Workbook
Set wb = ThisWorkbook
Now wb will be referenced to ThisWorkbook Object. With Worksheets is the same. You refer exactly the same way:
Dim ws as Worksheet
Set ws = ActiveSheet
Now ws is referenced to activesheet and you can handle it from ws.
I hope this answered some of your doubts. About your code, the loop part should be something like this:
Dim MyWb As Workbook 'variable for workbook
Dim MyWs As Worksheet 'variable for worksheet
ThisWorkbook.Activate
Range("A2").Select
'DO While
Do While ActiveCell.Value <> ""
ThisWorkook.Activate
Set MyWb = Workbooks.Open(Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True) ' to be sure read-only open
' Worksheet Open from D2
Set MyWs = MyWb.Worksheets(ActiveCell.Offset(0, 3).Value) 'now MyWs is referenced to the worksheet in column D
'Copy Range from E2
MyWs.Activate
MyWs.Range(ActiveCell.Offset(0, 4).Value).Copy 'we copy the range shown in column E
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile + title from F2
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'after pasting, we go back to active workbook
Application.CutCopyMode = False
MyWb.Activate
MyWb.Close SaveChanges:=False ' close file and don't save
Set MyWs = Nothing
Set MyWb = Nothing
ActiveCell.Offset(1, 0).Select 'we go 1 row down
Loop
I hope you can test it and tell me if it helped you to make thing clear :)
Really Thanks for answer
I had to use "ThisWorkbook.Activate" in a few places.
And now this macro work almost perfect.. it means that the order of creating slides is reversed : 1 is the last and the last is 1..
What is more I'd like to also create Title of each slide from Excel file column F.
Below my VBA code:
Sub VBA_PowerPoint()
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim MyWb As Workbook 'variable for workbook
Dim MyWs As Worksheet 'variable for worksheet
Dim MyRg As Excel.Range ' variable for Range
Application.DisplayAlerts = False
ThisWorkbook.Activate
Range("A2").Select
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Do While
ThisWorkbook.Activate
Do While ActiveCell.Value <> ""
ThisWorkbook.Activate
Set MyWb = Workbooks.Open(Filename:=(ActiveCell.Offset(0, 1) & "\" & ActiveCell.Offset(0, 2)), UpdateLinks:=0, ReadOnly:=True) ' to be sure read-only open
' Worksheet Open from D2
ThisWorkbook.Activate
Set MyWs = MyWb.Worksheets(ActiveCell.Offset(0, 3).Value) 'now MyWs is referenced to the worksheet in column D
'Copy Range from E2
' Set MyRg = MyWs.Range(ActiveCell.Offset(0, 4).Value) 'now MyWs is referenced to the worksheet in column E
' MyWs.Range(MyRg).Copy 'we copy the range shown in column E
ThisWorkbook.Activate
MyWs.Range(ActiveCell.Offset(0, 4).Value).Copy
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile + title from F2
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'after pasting, we go back to active workbook
Application.CutCopyMode = False
MyWb.Activate
MyWb.Close SaveChanges:=False ' close file and don't save
Set MyWs = Nothing
Set MyWb = Nothing
ActiveCell.Offset(1, 0).Select 'we go 1 row down
Loop
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub

Copy from Excel Worksheets to specific Powerpoint slides

I am transferring data from excel to powerpoint slides with an automated script by using EXcel VBA. I'm trying to copy the usedrange of a excel worksheet and paste it to as a image in a powerpoint Template of 4th slide and from there on it should add new slides and copy the remaining worksheets to the next further slides.
So, In my code for the first iteration it is copying from excel worksheet of first sheet and pasting it in the 4th slide but for the next iteration it is throwing the error as below:
The code which i'm currently using is getting the following error
"Run Time Error -2147188160(80048240) AutomationError".
I'm new to Excel VBA. Please help
Can anyone suggest me the code for the following.
Hope this is clearly explained. If not please ask for more clarification.
Thanks
Private Sub CommandButton2_Click()
Dim PP As PowerPoint.Application
Dim PPpres As Object
Dim PPslide As Object
Dim PpTextbox As PowerPoint.Shape
Dim SlideTitle As String
Dim SlideNum As Integer
Dim WSrow As Long
Dim Sh As Shape
Dim Rng As Range
Dim myshape As Object
Dim myobject As Object
'Open PowerPoint and create new presentation
Set PP = GetObject(class, "PowerPoint.Application")
PP.Visible = True
Set PPpres = PP.Presentations.Open("\\C:\Users\Templates")
'Specify the chart to copy and copy it
For Each WS In Worksheets
If (WS.Name) <> "EOS" Then
ThisWorkbook.Worksheets(WS.Name).Activate
ThisWorkbook.ActiveSheet.UsedRange.CopyPicture
lastrow = ActiveSheet.UsedRange.Rows(ActiveSheet.UsedRange.Rows.Count).Row
'Copy Range from Excel
Set Rng = ThisWorkbook.ActiveSheet.Range("A1:I" & lastrow)
'Copy Excel Range
Rng.Copy
For k = 4 To 40
slidecount = PPpres.Slides.Count
PP.ActiveWindow.View.GotoSlide (k)
'Paste to PowerPoint and position
Set PPslide = PPpres.Slides(k)
PPslide.Shapes.PasteSpecial DataType:=10 '2 = ppPasteEnhancedMetafile
Set myshape = PPslide.Shapes(PPslide.Shapes.Count)
'Set position:
myshape.Left = 38
myshape.Top = 152
'Add the title to the slide
SlideTitle = "Out of Support, " & WS.Name & " "
Set PpTextbox = PPslide.Shapes.AddTextbox(msoTextOrientationHorizontal,
0, 20, PPpres.PageSetup.SlideWidth, 60)
PPslide.Shapes(1).TextFrame.TextRange = SlideTitle
'Set PPslide = PPpres.Slides.Add(slidecount + 1, ppLayoutTitle)
'Make PowerPoint Visible and Active
PP.Visible = True
PP.Activate
'Clear The Clipboard
Application.CutCopyMode = False
Next k
Exit For
End If
Next WS
End Sub

How to paste excel data into powerpoint and still allow the user to edit data

I was wondering if there was a way of exporting/pasting an excel range into powerpoint, while still allowing the user to edit the result. The code I keep seeing on the internet pastes data from excel into powerpoint as a picture. Below is an example:
Sub export_to_ppt(ByVal sheetname As String, ByVal initialSelection As String) ', ByVal cols As Integer, ByVal rows As Integer)
Application.ScreenUpdating = False
Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
'Copy Range from Excel
'Set rng = ThisWorkbook.ActiveSheet.Range("B17:D50")
'Create an Instance of PowerPoint
On Error Resume Next
'Is PowerPoint already opened?
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then open PowerPoint
If PowerPointApp Is Nothing Then Set PowerPointApp = CreateObject(class:="PowerPoint.Application")
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Optimize Code
Application.ScreenUpdating = False
'Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 12) '12 = ppLayoutBlank
'Copy Excel Range
Dim rowCount As Integer
Dim colcount As Integer
Dim i As Integer
Dim No_sheets As Integer
No_sheets = Worksheets("Control_Sheet").Range("AP2").Value + 2
For i = 3 To No_sheets
Worksheets("Control_Sheet").Activate
Worksheets("Control_Sheet").Cells(i, 42).Select
If Worksheets("Control_Sheet").Cells(i, 42).Value = sheetname Then
rowCount = Worksheets("Control_Sheet").Cells(i, 44).Value
colcount = Worksheets("Control_Sheet").Cells(i, 43).Value
GoTo resume_copy
End If
Next i
resume_copy:
Worksheets(sheetname).Activate
Worksheets(sheetname).Range(initialSelection).Select
Selection.Resize(rowCount, colcount).Select
Selection.Copy
'Paste to PowerPoint and position
Application.Wait Now + TimeValue("00:00:01")
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = 1
myShape.Top = 1
myShape.Width = 950
PowerPointApp.Visible = True
PowerPointApp.Activate
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub
Replace:
mySlide.Shapes.PasteSpecial DataType:=2
With:
mySlide.Shapes.PasteSpecial DataType:=ppPasteOLEObject, DisplayAsIcon:=msoFalse, link:=msoFalse
Hope this helps,
TheSilkCode
You can, but this process was very buggy for me when running a large ppt deck. This works by using the ppt shapes position as the location of the paste. Use a template ppt slide to test, you can paste tables and graphs this way.
Dim myApp As PowerPoint.Application
Dim myPres As PowerPoint.Presentation
Dim myStatsSlide As PowerPoint.Slide
Set myApp = New PowerPoint.Application
Set myPres = myApp.ActivePresentation
Set myStatsSlide = myPres.Slides(1)
Dim mySheet As Worksheet
Set mySheet = ActiveSheet
'Copy table as table, not image
Dim mySumTable As Range
Set mySumTable = mySheet.Range("A1:C5")
mySumTable.Copy
myStatsSlide.Shapes.Placeholders(1).Select
myPres.Windows(1).View.Paste
'Copy Chart, as chart not image
Dim monoChart As ChartObject
'MONO CHART
monoChart.Select
ActiveChart.ChartArea.Copy
Debug.Print monoChart.Name
myStatsSlide.Shapes.Placeholders(2).Select
myPres.Windows(1).View.Paste
Debug.Print monoChart.Name

How can I Make PowerPoint slides for excel each Range in VBA

How can I make powerpoint slides based on Excel Range A2:B2. All the characters(countryname) for excel rows A1 to A10 make it as a Powerpoint Slide.
Here is the Code that is throwing an array error:
Sub PasteMultipleSlides()
Dim myPresentation As Object
Dim mySlide As Object
Dim PowerPointApp As Object
Dim shp As Object
Dim MySlideArray As Variant
Dim MyRangeArray As Variant
Dim x As Long
On Error Resume Next
Set PowerPointApp = GetObject(class:="PowerPoint.Application")
'Clear the error between errors
Err.Clear
'If PowerPoint is not already open then Exit
If PowerPointApp Is Nothing Then
MsgBox "PowerPoint Presentation is not open, aborting."
Exit Sub
End If
'Handle if the PowerPoint Application is not found
If Err.Number = 429 Then
MsgBox "PowerPoint could not be found, aborting."
Exit Sub
End If
On Error GoTo 0
'Make PowerPoint Visible and Active
PowerPointApp.ActiveWindow.Panes(2).Activate
'Create a New Presentation
Set myPresentation = PowerPointApp.ActivePresentation
'List of PPT Slides to Paste to
MySlideArray = Array(2, 3, 4, 5, 6)
'List of Excel Ranges to Copy from
MyRangeArray = Array(Sheet1.Range("A2:B10"))
'Loop through Array data
For x = LBound(MySlideArray) To UBound(MySlideArray)
'Copy Excel Range
MyRangeArray(x).Copy
'Paste to PowerPoint and position
On Error Resume Next
Set shp = myPresentation.Slides(MySlideArray(x)).Shapes.PasteSpecial(DataType:=2) 'Excel 2007-2010
Set shp = PowerPointApp.ActiveWindow.Selection.ShapeRange 'Excel 2013
On Error GoTo 0
'Center Object
With myPresentation.PageSetup
shp.Left = (.SlideWidth \ 2) - (shp.Width \ 2)
shp.Top = (.SlideHeight \ 2) - (shp.Height \ 2)
End With
Next x
'Transfer Complete
Application.CutCopyMode = False
ThisWorkbook.Activate
MsgBox "Complete!"
End Sub

Export entire Excel workbook to PowerPoint presentation

I have an 11 page Excel workbook with pages with multiple charts on one page, just text on some pages, single charts and all types of things. And I just want each sheet to export to one slide of a PowerPoint presentation.
Here is some code I found that exports all the charts and text to one slide and that's not what I need (this is code that is used frequently I found out):
'First we declare the variables we will be using
Dim newPowerPoint As PowerPoint.Application
Dim activeSlide As PowerPoint.Slide
Dim cht As Excel.ChartObject
'Look for existing instance
On Error Resume Next
Set newPowerPoint = GetObject(, "PowerPoint.Application")
On Error GoTo 0
'Let's create a new PowerPoint
If newPowerPoint Is Nothing Then
Set newPowerPoint = New PowerPoint.Application
End If
'Make a presentation in PowerPoint
If newPowerPoint.Presentations.Count = 0 Then
newPowerPoint.Presentations.Add
End If
'Show the PowerPoint
newPowerPoint.Visible = True
'Loop through each chart in the Excel worksheet and paste them into the PowerPoint
For Each cht In ActiveSheet.ChartObjects
'Add a new slide where we will paste the chart
newPowerPoint.ActivePresentation.Slides.Add newPowerPoint.ActivePresentation.Slides.Count + 1, ppLayoutText
newPowerPoint.ActiveWindow.View.GotoSlide newPowerPoint.ActivePresentation.Slides.Count
Set activeSlide = newPowerPoint.ActivePresentation.Slides(newPowerPoint.ActivePresentation.Slides.Count)
'Copy the chart and paste it into the PowerPoint as a Metafile Picture
cht.Select
ActiveChart.ChartArea.Copy
activeSlide.Shapes.PasteSpecial(DataType:=ppPasteMetafilePicture).Select
'Set the title of the slide the same as the title of the chart
activeSlide.Shapes(1).TextFrame.TextRange.Text = cht.Chart.ChartTitle.Text
'Adjust the positioning of the Chart on Powerpoint Slide
newPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 15
newPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 125
activeSlide.Shapes(2).Width = 200
activeSlide.Shapes(2).Left = 505
Next
AppActivate ("Microsoft PowerPoint")
Set activeSlide = Nothing
Set newPowerPoint = Nothing
Now I have some code that exports table I created programmatically but I get errors when I try to export my Excel presentation:
Sub ExportToPPT()
Dim ws As Worksheet
'Open Power Point and create a new presentation.
Set pptApp = CreateObject("Powerpoint.Application")
Set pptPres = pptApp.Presentations.Add
'Show the Power Point application.
pptApp.Visible = True
For Each ws In ActiveWorkbook.Worksheets
ws.Activate
ExcelTableToPowerPoint (ActiveSheet.Range("A1:L5"))
Next ws
'Return the "focus" to the frist sheet.
ActiveWorkbook.Worksheets(1).Activate
'Infrom the user that the macro finished.
MsgBox "The ranges were successfully copied to the new presentation!", vbInformation, "Done"
End Sub
Got a solution to my answer, hope this helps others:
'variables
Dim pp As Object
Dim PPPres As Object
Dim PPSlide As Object
Dim xlwksht As Worksheet
Dim SlideCount As Long
Dim row As Long
'pp variable = Create a new powerpoint presentation
Set pp = CreateObject("PowerPoint.Application")
'Powerpoint presentation = add the object (the finished product) to the poewrpoint presentation
Set PPPres = pp.Presentations.Add
'powerpoint is now visible
pp.Visible = True
'range you pick for selection
MyRange = "A2:U41"
'For each worksheet in the active workbook select all the worksheets and wait however many seconds
For Each xlwksht In ActiveWorkbook.Worksheets
xlwksht.Select
Application.Wait (Now + TimeValue("0:00:1"))
'copy the picture from the range you selected
xlwksht.Range(MyRange).CopyPicture _
Appearance:=xlScreen, Format:=xlPicture
'Slide count
SlideCount = PPPres.Slides.Count
Set PPSlide = PPPres.Slides.Add(SlideCount + 1, 12)
PPSlide.Select
'paste the shapes
PPSlide.Shapes.Paste
pp.ActiveWindow.Selection.ShapeRange.Top = 1
pp.ActiveWindow.Selection.ShapeRange.Left = 1
pp.ActiveWindow.Selection.ShapeRange.Width = 700
Next xlwksht
pp.Activate
'Cleans it up
Set PPSlide = Nothing
Set PPPres = Nothing
Set pp = Nothing