I need to get a range form an excel sheet and use in this code to copy and paste it on a powerpoint presentation. I think the range doesnt work like that anymore but I dont have any idea on another way of doing that, any tips?
Sub PPTableMacro()
Dim oPPTApp As PowerPoint.Application
Dim oPPTShape As PowerPoint.Shape
Dim oPPTFile As PowerPoint.Presentation
Dim SlideNum As Integer
Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
strPresPath = "filepath"
strNewPresPath = "filepath"
Set oPPTApp = CreateObject("PowerPoint.Application")
oPPTApp.Visible = msoTrue
Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
SlideNum = 1
oPPTFile.Slides(SlideNum).Select
'Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("ws22")
Set ws = ThisWorkbook.Sheets("SHEET")
Set Table = ThisWorkbook.Sheets("SHEET").range("A2:A15,D2:D15,J2:J15,L2:L15,R2:R15")
Table.CopyPicture xlPrinter, xlPicture '<------ERROR HERE!
'SlideNum = SlideNum + 1
oPPTFile.Slides(1).Shapes.PasteSpecial (ppPastePicture)
oPPTFile.Slides(SlideNum).Select
End Sub
EDIT: thanks for all the answers and ideas!!! Saw this post and it worked for me:
Set ws = ThisWorkbook.Sheets("SHEET")
ThisWorkbook.Sheets("SHEET").Activate
Set rngToCopy = Application.Union(range("A2:A15"), range("D2:D15"), range("J2:J15"), range("L2:L15"), range("R2:R15"))
rngToCopy.Copy
ws.range("AA1").PasteSpecial xlPasteValues
'Table.CopyPicture xlPrinter, xlPicture
oPPTFile.Slides(1).Shapes.PasteSpecial (ppPastePicture)
oPPTFile.Slides(SlideNum).Select
2
Range("A2:A15,D2:D15,J2:J15,L2:L15,R2:R15").CopyPicture xlPrinter, xlPicture
I quick test in Excel indicates that the Range.CopyPicture does not work on multiple selections.
I would add another worksheet to the Excel file and gather the data into a single block of contiguous (connected) cells.
Black cat is right in pointing out the OP is running the file from Excel and will need a reference to the Power Point library. I assume he does because the use PowerPoint.Application.
3
CopyPicture doesn’t work on mulitple selections. The source range to be copied must consist of a continuous block of cells. (@TinMan posted the answer before my comment)
There is a workaround to copy non-continuous columns all at once.
Note: The script may not work perfectly for all non-continuous ranges and has only been tested for the original poster’s scenario.
Sub CopyMultiAreasRange()
Dim sRng As Range, firstC As Range, lastC As Range
With ThisWorkbook.Sheets(1)
Set sRng = .Range("A2:A15,D2:D15,J2:J15,L2:L15,R2:R15")
Set firstC = sRng.Areas(1).Cells(1)
With sRng.Areas(sRng.Areas.Count)
Set lastC = .Cells(.Cells.Count)
End With
For i = firstC.Column To lastC.Column
If Intersect(sRng, .Columns(i)) Is Nothing Then
.Columns(i).Hidden = True
End If
Next
Range(firstC, lastC).CopyPicture xlPrinter, xlPicture
' *** for testing
.Activate
.Range("A18").Select
.Paste
' ***
.Columns.Hidden = False
End With
End Sub
1