VBA Help required

nikhil0311 · Aug 30, 2018

I have this below code and it is WORKING FINE.

I have a dropdown list in column A1 and its data validation range is H1:H4. i have applied loop so its changing the drop down value automatically

then below code is copying excel range A1:E9 and pasting as image in PowerPoint slide.

what I am looking here is to loop the 2nd part of code which will paste images in new slides within the same workbook.

Book1

A

B

C

D

E

F

G

H

1

D

A

2

Casid

Name

Product

Rev

Stage

B

3

1

A

Liq

3

Closed

C

4

2

B

CC

5

bid

D

5

3

C

TS

7

mandate

6

4

D

FX

3

bid

7

5

E

Liq

8

bid

8

6

F

FX

9

mandate

9

7

G

CC

6

Closed

Sheet1

Sub dropdown()

Dim rdata As Range
Dim c As Range
Set rdata = ThisWorkbook.Sheets("Sheet1").Range("$H$1:$h$4") 'Save the range the dropdown data is in

For Each c In rdata.Cells
ThisWorkbook.Sheets(1).Range("$A$1").Value = c.Value
Next

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("A1:E9")

'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, 11) '11 = ppLayoutTitleOnly

'Copy Excel Range
rng.Copy

'Paste to PowerPoint and position
mySlide.Shapes.PasteSpecial DataType:=2 '2 = ppPasteEnhancedMetafile
Set myShape = mySlide.Shapes(mySlide.Shapes.Count)

'Set position:
myShape.Left = 66
myShape.Top = 152

'Make PowerPoint Visible and Active
PowerPointApp.Visible = True
PowerPointApp.Activate

'Clear The Clipboard
Application.CutCopyMode = False

End Sub

VBA Help required

nikhil0311

Board Regular

Excel Facts

Similar threads

Forum statistics

Share this page

VBA Help required

nikhil0311

Board Regular

Excel Facts

Similar threads

Forum statistics

Share this page

We've detected that you are using an adblocker.

Which adblocker are you using?

Disable AdBlock

Disable AdBlock Plus

Disable uBlock Origin

Disable uBlock