copying a range in excel pasting in powerpoint - vba

I have this code which copies a shape called pastedpic 19 which is shape 17 in my Excel file and then opens a new PowerPoint slide and pastes it.Problem is i want it to be copied as normal ranges and pasted as a copy of this so i can Change datas there.
Sub exceltoPPT()
Dim PowerPointapp as Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim DestinationSheet7 As Worksheet
Dim DestinationSheet1 As Worksheet
Dim pastedPic3 As Shape
Set DestinationSheet1 = Workbooks("1_1_1_tt.xlsm").Sheets("Eingabefeld")
Set pastedPic9 = DestinationSheet1.Shapes(17)
' Create a New Presentation
Set myPresentation = PowerPointApp.Presentations.Add
'Add a slide to the Presentation
Set mySlide = myPresentation.Slides.Add(1, 11) '11 = ppLayoutTitleOnly
'pastedPic9.Copy
Windows(anan).Activate
Sheets("Eingabefeld").Range("B1:ES44").CopyPicture Appearance:=xlPrinter,Format:=xlPicture
'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)
'Set position:
myShape.Left = -15
myShape.Top = 11
End Sub
Does anyone know how to do this?

try this
Sub Export_xls2pp()
'
'=======================================================================================
' Procedure : Export_xls2pp (Sub)
' Module : Module1 (Module)
' Project : VBAProject
' Author : yann LE DIRACH
' Date : 11/03/2016
' Comments : eXPORT XLS RANGE INTO POWERPOINT TABLE
' ADD REFERENCE TO POPERPOINT LIBRARY (EARLY BINDING)
' Unit Test : () 11/03/2016 10:11 | Description [OK]
' Arg./i :
' - [NO PARAM]
' -
' -
' Arg./o : ()
'
'Changes--------------------------------------------------------------------------------
'Date Programmer Change
'11/03/2016 yann LE DIRACH Initiate
'
'=======================================================================================
'
Dim opp As PowerPoint.Application
Dim oppp As PowerPoint.Presentation
Dim oppps As PowerPoint.Slide
Dim opps_s As PowerPoint.Shape
Dim opps_t As Table
Dim orng As Range
'Note : current xls range
Set orng = ActiveSheet.Range("A1:C6")
'Note : add powerpoint doc
Set opp = CreateObject("Powerpoint.Application")
Set oppp = opp.Presentations.Add
With oppp
'Note : add slide
Set oppps = .Slides.Add(1, ppLayoutBlank)
With oppps
'Note : add slide > set to table > dim table with xls range settings
Set opps_s = .Shapes.AddTable(orng.Rows.Count, orng.Columns.Count)
Set opps_t = opps_s.Table
'Note : loop throught rng and populate powerpoint table
For i = 1 To orng.Rows.Count
For j = 1 To orng.Columns.Count
opps_t.Cell(i, j).Shape.TextFrame.TextRange.Text = orng.Cells(i, j).Value
Next j
Next i
End With
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

excel to powerpoint Shapes.PasteSpecial DataType:=0 random error

I am having trubbles with a VBA project. My goal is to make a powerpoint from an excel. Each line in the excel make a new slide, and all info are automatically placed.
All rows have the same column number.
Only one sheet in workbook, so no problem with Activesheet.name.
I have pictures and text in random order, this is why I used ppPastedefault for the type of the shape.
Some cells can be empty, this is why I used the on error.
Program launch, you chose the slide template. Then, fo each cells of the first row from excel, you place the shape (text or picture) where you want on the powerpoint slide. Positions are saved in arrays. When all shapes from the first row are placed into the slide, it automatically make all the others slides (all shapes are placed in good position).
this is working "fine", but random errors appears :
Private Sub CommandButton1_Click()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.slide
Dim Wks As Worksheet
Dim Ncol As Integer, Nrow As Integer, Y As Integer
Dim ExcRng As Variant, Tpath As Variant, Plage As Variant
Dim PLShape() As Variant, PTShape() As Variant, PHShape() As Variant
Dim myShape As Object
Set Wks = Sheets(ActiveSheet.Name)
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
'define row, column and choice of the ppt layout. Also dimensioning the Arrays'
Ncol = Wks.Cells(1, Columns.Count).End(xlToLeft).Column
Nrow = Wks.Cells(Rows.Count, "B").End(xlUp).Row
Set Plage = Wks.Range("B1:B" & Nrow)
Tpath = Application.GetOpenFilename(".potx,*.potx", , "Choisissez le template")
Y = 0
ReDim PTShape(Ncol - 1)
ReDim PLShape(Ncol - 1)
ReDim PHShape(Ncol - 1)
For Each Cell In Plage
'Loop through all rows'
Set PPTSlide = PPTPres.Slides.Add(Y + 1, ppLayoutBlank)
With PPTSlide
PPTSlide.ApplyTemplate (Tpath)
PPTSlide.CustomLayout = PPTPres.SlideMaster.CustomLayouts(1)
End With
Y = Y + 1
'Loop through all columns of each rows'
For x = 0 To Ncol - 1
Set ExcRng = Wks.Cells(Cell.Row, x + 1)
'On error is used to pass cells that are empty. Maybe I could test ExcRng instead, but can't make it work'
On Error GoTo suite:
'the problem should be around here i guess'
ExcRng.Copy
DoEvents
PPTSlide.Shapes.PasteSpecial DataType:=0
Set myShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
'If statement, if this is the first slide, then you place all shape one by one. If not, all shapes are placed automatically with, "copying" the first slide'
If Y = 1 Then
MsgBox "Enregistrer position"
PTShape(x) = myShape.Top
PLShape(x) = myShape.Left
PHShape(x) = myShape.Height
Else
myShape.Top = PTShape(x)
myShape.Left = PLShape(x)
myShape.Height = PHShape(x)
End If
suite:
On Error GoTo -1
Application.CutCopyMode = False
Next x
Next Cell
End Sub
I have 2 issues with the program, and i can't solve those :
sometime, the shape (text) are not in a textbox but are in a table shape, keeping format from excel.
sometime, shapes (both text or picture) are missing
This is completly random.
On other topics, solutions are :
put a Doevents after the copy, this is not working very well. This might have improve stability, but I still have errors.
put a Application.wait for 1 or 2 seconde, not working and this solution is not good for me.
put a Application.CutCopyMode = False after the shapes.pastespecial, also not working.
That's all I could do. Maybe I have a problem into the definition of shapes,slides or even the object myShapeis badly defined, but as the failure is random, this is very hard to control.
Any idea ?
Thanks in advance for the help,
In case someone has the same issue, I think this solve the problem :
For each cell, I check if it contains picture and if it is empty or not.
If it contains a picture, it is copied with DataType:=ppPasteDefault
If it is not empty, it is copied with DataType:=ppPasteText
If it is empty, it is copied with DataType:=ppPasteEnhancedMetafile
So the loop go through everything, even empty cells and does not need the error handler anymore.
Now, you can use the error handler to restart the loop if there is an error in the copy/paste process. This is not the most beautiful solution, but it is working so far.
However, if something is going wrong, the program will loop indefinitely... you have to declare all your shapes / object / text / picture well and use dataType:= correctly.
`Private Sub CommandButton1_Click()
Dim PPTApp As PowerPoint.Application
Dim PPTPres As PowerPoint.Presentation
Dim PPTSlide As PowerPoint.slide
Dim cshape As Shape
Dim cflag As Boolean
Dim Wks As Worksheet
Dim Ncol As Integer, Nrow As Integer, Y As Integer
Dim ExcRng As Variant, Tpath As Variant, Plage As Variant
Dim PLShape() As Variant, PTShape() As Variant, PHShape() As Variant
Dim myShape As Object
Dim Eshape As Shape
Set Wks = Sheets(ActiveSheet.Name)
Set PPTApp = New PowerPoint.Application
PPTApp.Visible = True
Set PPTPres = PPTApp.Presentations.Add
Ncol = Wks.Cells(1, Columns.Count).End(xlToLeft).Column
Nrow = Wks.Cells(Rows.Count, "B").End(xlUp).Row
Set Plage = Wks.Range("B1:B" & Nrow)
Tpath = Application.GetOpenFilename(".potx,*.potx", , "Choisissez le template")
Y = 0
ReDim PTShape(Ncol - 1)
ReDim PLShape(Ncol - 1)
ReDim PHShape(Ncol - 1)
On Error GoTo reprise:
For Each Cell In Plage
Set PPTSlide = PPTPres.Slides.Add(Y + 1, ppLayoutBlank)
'DoEvents'
With PPTSlide
PPTSlide.ApplyTemplate (Tpath)
PPTSlide.CustomLayout = PPTPres.SlideMaster.CustomLayouts(1)
'DoEvents'
End With
Y = Y + 1
For x = 0 To Ncol - 1
reprise:
On Error GoTo -1
Set ExcRng = Wks.Cells(Cell.Row, x + 1)
'DoEvents'
ExcRng.Copy
DoEvents
cflag = False
For Each cshape In Wks.Shapes
If cshape.TopLeftCell.Address = Wks.Cells(Cell.Row, x + 1).Address Then
cflag = True
GoTo suite:
End If
Next
suite:
If cflag Then
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteDefault
'DoEvents'
Else
If Wks.Cells(Cell.Row, x + 1) <> 0 Then
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteText
'DoEvents'
Else
PPTSlide.Shapes.PasteSpecial DataType:=ppPasteEnhancedMetafile
'DoEvents'
End If
End If
Set myShape = PPTSlide.Shapes(PPTSlide.Shapes.Count)
If Y = 1 Then
MsgBox "Enregistrer position"
PTShape(x) = myShape.Top
PLShape(x) = myShape.Left
PHShape(x) = myShape.Height
Else
myShape.Top = PTShape(x)
myShape.Left = PLShape(x)
myShape.Height = PHShape(x)
'DoEvents'
End If
Application.CutCopyMode = False
Next x
Next Cell
End Sub`
Thanks,

Why vba loop fails after the first round?

My code is suppose to create sheets, then charts on sheets with name "Sheet..." and then create a powerpoint. then it deletes all sheets and starts all over again. The charts creation part works, but when it comes to creating a powerpoint, the code hops over the IF-statement. It works the first round but after that it jumps over IF.
Dim ppt As PowerPoint.Application
Set ppt = New PowerPoint.Application
ppt.Visible = msoTrue
'Change template source if necessary
ppt.Presentations.Open "C:\Desktop\Template\PowerPoint_Template.potx", _
Untitled:=msoTrue
ppt.Activate
Dim ppt_pres As PowerPoint.Presentation
Set ppt_pres = ppt.ActivePresentation
Dim ppt_layout As CustomLayout
Set ppt_layout = ppt_pres.Slides(2).CustomLayout
Dim ppt_slide As PowerPoint.Slide
Set ppt_slide = ppt_pres.Slides.AddSlide(2, ppt_layout)
Dim ppt_shape As PowerPoint.Shape
Set ppt_shape = ppt_slide.Shapes(1)
Dim ppw As Object
Set ppw = ppt_pres.Windows(ppt_pres.Windows.Count)
Dim wsPIA As Worksheet
Set wsPIA = Sheet4
'Naming title slide
ppt_pres.Slides(1).Shapes(3).TextFrame.TextRange.Text = wsPIA.Range("C2")
ppt_pres.Slides(1).Shapes(2).TextFrame.TextRange.Text = wsPIA.Range("I2")
'Identifying number of sheets that contain newly created charts
Dim j As Integer, vNames() As Variant, ws As Worksheet, picture As Shape
j = 0
For Each ws In ThisWorkbook.Worksheets
If Left(ws.Name, 5) = "Sheet" Then
j = j + 1
ReDim Preserve vNames(j)
vNames(j) = ws.Name
End If
Next ws
Application.DisplayAlerts = False
'Looping copypaste of charts from excel to powerpoint
For Each ws In Worksheets
If Left(ws.Name, 5) = "Sheet" Then
ws.Select
For Each picture In ActiveSheet.Shapes
picture.Copy
ppw.View.GotoSlide ppt_pres.Slides.Count - 1
ppt_slide.Shapes.PasteSpecial ppPasteEnhancedMetafile
ppt_slide.Shapes(7).Height = 390
ppt.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, msoCTrue
ppt.ActiveWindow.Selection.ShapeRange.Align msoAlignMiddles, msoTrue
ppt_slide.Shapes(7).Top = ppt_slide.Shapes(7).Top + 14
ppt_slide.Shapes.Title.TextFrame.TextRange.Text = wsPIA.Range("C2")
ppt_slide.Shapes(4).TextFrame.TextRange.Text =wsPIA.Range("I2")
ppw.View.GotoSlide ppt_pres.Slides.Count - 1
Set ppt_slide = ppt_pres.Slides.AddSlide(ppt_pres.Slides.Count - 1, ppt_layout)
Next
End If
Next
'Deleting blank slides from the end
ppt_pres.Slides.item(ppt_pres.Slides.Count - 1).Delete
ppt_pres.Slides.item(ppt_pres.Slides.Count - 1).Delete
With ppt_pres
.SaveAs ("C:\Desktop\Presentations\Pres1.pptx")
.Close
End With
The first round, line:
If Left(ws.Name, 5) = "Sheet" Then ws. Select
is true but after the first iteration, it skips that and goes straight to
'Deleting blank slides from the end

How to enlarge and widen the photo as it can in ms word?

my program :
produce a picture that is extracting data from excel .
Paste it in word and make the page setting as Landscape .
However ,the picture generated is small and the setting of page become custom.
the photo is so wide .I don't want to enlarge by myself everytimes.
How can I add this setting in vba ?Make it as large and wide as it can .
Secondly , it is pleasure that the data extracted can be pasted as table format.
my codes :
Private Sub CommandButton1_Click()
Dim tbl0 As Excel.RANGE
Dim Tbl As Excel.RANGE
Dim tbl2 As Excel.RANGE
Dim wordApp As Word.Application
Dim myDoc As Word.Document
Dim WordTable As Word.Table
Dim wb As Workbook
Dim ws As Worksheet
Set wb = ThisWorkbook
Set ws = wb.Worksheets("17-18") ' Change e.g. sheet9.Name
'Optimize Code
Application.ScreenUpdating = False
Application.EnableEvents = False
Value1 = Me.TextBox1.Value
Value2 = Me.TextBox2.Value
ws.Rows("84:89").EntireRow.Hidden = True 'ADJUST AS APPROPRIATE
'Copy Range from Excel
'Set tbl0 = ws.RANGE("A78:I83")
Set Tbl = ws.RANGE("A78:I92")
' Set tbl2 = ws.Range("A90:I92")
'Create an Instance of MS Word
On Error Resume Next
'Is MS Word already opened?
Set wordApp = GetObject(Class:="Word.Application")
'Clear the error between errors
Err.Clear
'If MS Word is not already open then open MS Word
If wordApp Is Nothing Then Set wordApp = CreateObject(Class:="Word.Application")
'Handle if the Word Application is not found
If Err.Number = 429 Then
MsgBox "Microsoft Word could not be found, aborting."
GoTo EndRoutine
End If
On Error GoTo 0
'Make MS Word Visible and Active
wordApp.Visible = True
wordApp.Activate
'Create a New Document
Set myDoc = wordApp.Documents.Add
'Trigger copy separately for each table + paste for each table
Tbl.CopyPicture Appearance:=xlScreen, Format:=xlPicture
wordApp.Selection.Paste
wordApp.Selection.TypeParagraph
wordApp.Selection.PageSetup.Orientation = wdOrientLandscape
resize_all_images_to_page_width myDoc
EndRoutine:
'Optimize Code
Application.ScreenUpdating = True
Application.EnableEvents = True
'Clear The Clipboard
Application.CutCopyMode = False
End Sub
Although I don't fiddle with Word but Excel only it might give you an idea...
The code of my XmasPrep excel sucks in a bunch of pictures in order to produce a catalog, listing the pictures to select from.
For each line, i.e. each picture, the code
assigns an Excel cell range and then resizes the range ROW height and width
as well as the range height itself
assigns the picture object thisPic = .Parent.Pictures.Insert(picFileName) and then resizes that according to the cell range's coordinates and size:
thisPic.Top = .Top + 1
thisPic.Left = .Left + 1
thisPic.Width = .Width - 2
thisPic.Height = .Height - 2
So, if you're able to grab the picture object (thisPic) in Word you might be able to resize it to your needs as well. Hope it helps.
:
Const MaxHeight = 50
Const MaxWidth = 14
Dim picFileName As String
Dim i, j, k As Long
Dim col_Filenames As Long
Dim col_Pictures As Long
Dim range_PicCell As Range
Dim thisPic As Picture
:
picFileName = filesPath & select2order.Cells(i, col_Filenames).Value
Set range_PicCell = select2order.Cells(i, col_Pictures)
range_PicCell.RowHeight = MaxHeight
range_PicCell.ColumnWidth = MaxWidth
With range_PicCell
.Height = MaxHeight
Set thisPic = .Parent.Pictures.Insert(picFileName)
thisPic.Top = .Top + 1
thisPic.Left = .Left + 1
thisPic.Width = .Width - 2
thisPic.Height = .Height - 2
End With
:

Copying Range from Excel to Powerpoint and change alignment with vba

I am trying to copy a range from Excel into PowerPoint using vba.
Copying and Pasting are no Problem, but i canĀ“t get the text in the created PowerPoint table to be aligned right (and vertical Center).
Here is the part how i copy and paste the range:
Dim myWks As Excel.Worksheet
Dim ppSlide As PowerPoint.Slide
wksData.Range("A2:A5").Copy
ppSlide.Shapes.PasteSpecial
Set MyShape = ppSlide.Shapes(ppSlide.Shapes.Count)
MyShape.Top = x
MyShape.Height = y
MyShape.Width = z
MyShape.Left = m
Now I Need something like MyShape.Align = Right (which of course is not working).
Can someone help me with this?
Thx a lot!
Try the following procedure, it works on my Excel file.
You need to have an open PowerPoint, this sub-routine will scan column A in your Excel file (starting from the second row).
It will create a new slide at the end of the open PowerPoint, and will create a Table with the number of rows it found text in your Excel worksheet column A.
At last it will store each Excel's row data in in the new Table.
Sub Export_to_PPT_Table()
Dim wksData As Excel.Worksheet
Dim PPT As PowerPoint.Application
Dim ppslide As PowerPoint.Slide
Dim ppShape As PowerPoint.Shape
Dim ppTable As PowerPoint.Table
' in brackets add your worksheet name
Set wksData = ActiveWorkbook.Worksheets("Sheet2")
Set PPT = New PowerPoint.Application
PPT.Visible = True
'Add a blank slide at the end of an existing PowerPoint
Set ppslide = PPT.ActivePresentation.Slides.Add(PPT.ActivePresentation.Slides.Count + 1, PowerPoint.PpSlideLayout.ppLayoutBlank)
Dim Excel_numofRows As Integer
ExcelRow = 2
' loop through your excel file in Column A, and check for last row with existing text inside
While wksData.Cells(ExcelRow, 1) <> ""
Excel_numofRows = ExcelRow
ExcelRow = ExcelRow + 1
Wend
' create a new Table in the new slide created
' in brackets is where you play with your table's properties
Set ppShape = ppslide.Shapes.AddTable(Excel_numofRows, 1, 100, 100, PPT.ActivePresentation.PageSetup.SlideWidth - 300, 150)
Set ppTable = ppShape.Table
ExcelRow = 2
While wksData.Cells(ExcelRow, 1) <> ""
With ppTable
.Cell(ExcelRow - 1, 1).Shape.TextFrame.TextRange.Text = wksData.Cells(ExcelRow, 1)
.Cell(ExcelRow - 1, 1).Shape.TextFrame.TextRange.ParagraphFormat.Alignment = msoTextEffectAlignmentRight
.Cell(ExcelRow - 1, 1).Shape.TextFrame.VerticalAnchor = msoAnchorMiddle
End With
ExcelRow = ExcelRow + 1
Wend
End Sub