Excelmacros从Excel工作表中复制表格，并将其粘贴到PowerPoint幻灯片的灵活性，以dicede哪colomuns和行

我想复制Excel表格并将其粘贴到幻灯片中。 用户应该能够决定哪些列和行将被移植，即哪些列和行将被转换为ppt表。 我到现在得到的是复制整个表并粘贴，但我没有成功，让用户这种灵活性来select列和行。 这就是我写的：

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

下面的部分只是用户select想要导出的行数（从第一行开始）和列数（从第一列开始）的一个例子，您可以将其扩展为任何您需要的值。

 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