Copying the currently selected cells to powerpoint 2007

[MeisterMan]

Hello,

I am interested in creating a macro that will copy cells that I select and paste that selection into PowerPoint 2007. The cells will be different each time so " Range ("A1:B14").Select " will not suffice because the range on the next selection could be A1:B3. I guess the word would be a dynamic range (of course I could be wrong).

Any help is greatly appreciated!!

Thank you,
MeisterMan

[MeisterMan]

I thought about this after my original post but I already have the code for copying to PowerPoint. What I need is the VBA to copy what is currently selected in the spreadsheet.

Here is what I have currently. As you can tell the top line copies the range. This is where I need the help.

Sub Copy_Paste_to_PowerPoint()

Range("A1:J43").Select

'Requires a reference to the Microsoft PowerPoint Library via the Tools - Reference menu in the VBE
Dim ppApp As PowerPoint.Application
Dim ppSlide As PowerPoint.Slide

Dim msg As String
Dim temp As Variant

Dim PasteChart As Boolean
Dim PasteChartLink As Boolean

Dim lHeight As Long
Dim lWidth As Long

'Look for existing instance of PowerPoint
On Error Resume Next
Set ppApp = GetObject(, "PowerPoint.Application")
On Error GoTo 0

'Sets current slide to active slide
Set ppSlide = ppApp.ActiveWindow.View.Slide

'Copy Range/Chart?
temp = MsgBox("Do you want to Copy-Paste Chart or Range? Yes=Chart ; No=Range", vbYesNo)
If temp = 6 Then
PasteChart = True
Else
PasteChart = False
End If

'Pasting a Chart
If PasteChart = True Then
Select Case TypeName(Selection)
'Paste Chart/Charts
Case "Chart", "ChartArea"
'Paste Chart as picture/link?
temp = MsgBox("Paste chart as a picture? Yes=Picture ; No=Link", vbYesNo)
If temp = 7 Then
PasteChartLink = True
Else
PasteChartLink = False
End If
'Copy Paste action
If PasteChartLink = True Then
'Copy & Paste Chart Linked
'ActiveChart.ChartArea.Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(link:=True).Select
Else
'Copy & Paste Chart Not Linked
'ActiveChart.CopyPicture Appearance:=xlScreen, Size:=xlScreen, Format:=xlPicture
'ppSlide.Shapes.Paste.Select
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
End If
'Paste DrawingObjects (Multiple charts/drawing objects)
Case "DrawingObjects"
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteEnhancedMetafile).Select
Case Else
msg = MsgBox("Select a Chart and run macro", vbOKOnly, "Select a Chart")
'End Sub
End Select
'Pasting a Range
Else
'Paste Chart as picture/link?
temp = MsgBox("Paste Range as a picture? Yes=Picture ; No=Link", vbYesNo)
If temp = 7 Then
PasteRangeLink = False
Else
PasteRangeLink = True
End If
'Options for Copy & Paste Ranges
If RangePasteType = True Then
'Paste Range as Picture
'Worksheets(SheetName).Range(RangeName).Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteMetafilePicture).Select
Else
'Paste Range as Picture Link
'Worksheets(SheetName).Range(RangeName).Copy
Selection.Copy
ppSlide.Shapes.PasteSpecial(ppPasteMetafilePicture, link:=msoTrue).Select
End If
End If


' Get the slide height and width.
lHeight = ppApp.ActivePresentation.PageSetup.SlideHeight
lWidth = ppApp.ActivePresentation.PageSetup.SlideWidth

' Set Height & Width of pasted object to fit the slide
If ppApp.ActiveWindow.Selection.ShapeRange.Height > lHeight Then
ppApp.ActiveWindow.Selection.ShapeRange.Height = lHeight
'ppApp.ActiveWindow.Selection.ShapeRange.Height = 400
End If
If ppApp.ActiveWindow.Selection.ShapeRange.Width > lWidth Then
ppApp.ActiveWindow.Selection.ShapeRange.Width = lWidth
'ppApp.ActiveWindow.Selection.ShapeRange.Width = 600
End If

' Center pasted object in the slide
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
ppApp.ActiveWindow.Selection.ShapeRange.Align msoAlignBottoms, True


' Activate PowerPoint window
AppActivate ("Microsoft PowerPoint")
Set ppSlide = Nothing
Set ppApp = Nothing

End Sub