Vba Excel宏从Excel工作表复制表格，并将其粘贴到PowerPoint幻灯片中，可以灵活地对列和列进行分块

我想复制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

你能帮我解决这个问题吗

---

非常感谢

下面的部分只是一个示例，用户可以选择要导出的行数（从第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

---

下面的部分只是一个示例，用户可以选择要导出的行数（起始行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

---

您需要让用户修改设置rng=thiswoolk.ActiveSheet.Range（“A1:J62”），对吗？您希望用户如何选择哪些列和行？通过

输入框

？通过

用户表单

？是的，对！并希望他通过InputBox选择它参见下面的我的答案您需要让用户修改

设置rng=thiswook.ActiveSheet.Range（“A1:J62”）

，对吗？您希望用户如何选择哪些列和行？通过

输入框

？通过

用户表单

？是的，对！并希望他通过InputBox选择它查看下面的答案