Excel 宏从 Excel 工作表复制表格并将其粘贴到 PowerPoint 幻灯片中，灵活地决定哪些列和行

Question

I want to copy an Excel table and paste it into a Powerpoint slide. The user should be able to decide which columns and rows will be ported, ie which columns and rows will be translated to the ppt table. What I get until now is to copy the whole table and paste it but i didn't success to give the user this flexibility to choose the columns and rows.

This is what I wrote:

Sub ExcelRangeToPowerPoint()

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object

Set rng = ThisWorkbook.ActiveSheet.Range("A1:J62")

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 = 10
myShape.Top = 10

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

'Clear The Clipboard
Application.CutCopyMode = False

End Sub

can you help me please solve this problem?

thanks a lot!

Answer 1

The section below is just an example of a user selecting the number of rows he wants to export (starting Row 1) and number of Columns (starting Column A), you can expand it to whatever you need.

Sub ExcelRangeToPowerPoint()

Dim rng As Range
Dim PowerPointApp As Object
Dim myPresentation As Object
Dim mySlide As Object
Dim myShape As Object
Dim NumofCols   As Variant
Dim NumofRows   As Variant

' select number of rows to export
NumofRows = InputBox("Select number of rows you want to export from table (up to 62)")
If Not IsNumeric(NumofRows) Then
    MsgBox "Please select a valid Numeric value !", vbCritical
    End
Else
   NumofRows = CLng(NumofRows)
End If

' select number of columns you want to expot
NumofCols = InputBox("Select number of columns you want to export from table (up to 10)")
If Not IsNumeric(NumofCols) Then
    MsgBox "Please select a valid Numeric value !", vbCritical
    End
Else
    NumofCols = CLng(NumofCols)
End If

' set the Range starting fro Cell A1 >> you can modify it as you want
Set rng = ThisWorkbook.ActiveSheet.Range(Cells(1, 1), Cells(NumofRows, NumofCols))

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 = 10
myShape.Top = 10

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

'Clear The Clipboard
Application.CutCopyMode = False

End Sub