Excel 宏從 Excel 工作表復制表格並將其粘貼到 PowerPoint 幻燈片中，靈活地決定哪些列和行

Question

我想復制 Excel 表格並將其粘貼到 Powerpoint 幻燈片中。 用戶應該能夠決定哪些列和行將被移植，即哪些列和行將被轉換為 ppt 表。 到目前為止，我得到的是復制整個表並粘貼它，但我沒有成功地給用戶這種選擇列和行的靈活性。

這是我寫的：

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

你能幫我解決這個問題嗎？

多謝！

Answer 1

下面的部分只是一個用戶選擇他想要導出的行數（從第 1 行開始）和列數（從 A 列開始）的示例，您可以將其擴展為您需要的任何內容。

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