Question

我想复制一个Excel表格并将其粘贴到幻灯片中。用户应该能够决定将移植哪些列和行，即哪些列和行将被转换为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

Excel宏从Excel工作表中复制表并将其粘贴到具有flexibilty的PowerPoint幻灯片到dicede，其中colomuns和row

1 个答案: