如何用Excel VBA复制非连续多列并粘贴到PowerPoint？

问题场景 #

需要从Excel工作表中选取非连续列区域，通过VBA代码复制为图片并粘贴到PowerPoint演示文稿，但直接对非连续Range调用CopyPicture方法时出现报错。

原报错代码 #

Sub PPTableMacro()
    
    Dim oPPTApp As PowerPoint.Application
    Dim oPPTShape As PowerPoint.Shape
    Dim oPPTFile As PowerPoint.Presentation
    Dim SlideNum As Integer
    
    Dim strPresPath As String, strExcelFilePath As String, strNewPresPath As String
    strPresPath = "filepath"
    strNewPresPath = "filepath"

    Set oPPTApp = CreateObject("PowerPoint.Application")
    oPPTApp.Visible = msoTrue
    Set oPPTFile = oPPTApp.Presentations.Open(strPresPath)
    SlideNum = 1
    oPPTFile.Slides(SlideNum).Select
    
    'Set oPPTShape = oPPTFile.Slides(SlideNum).Shapes("ws22")
    
    Set ws = ThisWorkbook.Sheets("SHEET")
    Set Table = ThisWorkbook.Sheets("SHEET").Range("A2:A15,D2:D15,J2:J15,L2:L15,R2:R15")
    Table.CopyPicture xlPrinter, xlPicture '<------ERROR HERE!
    'SlideNum = SlideNum + 1
    
    oPPTFile.Slides(1).Shapes.PasteSpecial (ppPastePicture)
    oPPTFile.Slides(SlideNum).Select

End Sub

问题原因 #

CopyPicture方法无法直接作用于非连续的Range对象，这是导致报错的核心原因。

可行解决方案 #

通过将非连续区域先合并复制到工作表的空白连续区域，再进行后续的复制粘贴操作，绕过CopyPicture对非连续区域的限制。示例代码如下：

Set ws = ThisWorkbook.Sheets("SHEET")
ThisWorkbook.Sheets("SHEET").Activate
Set rngToCopy = Application.Union(Range("A2:A15"), Range("D2:D15"), Range("J2:J15"), Range("L2:L15"), Range("R2:R15"))
rngToCopy.Copy
ws.Range("AA1").PasteSpecial xlPasteValues

oPPTFile.Slides(1).Shapes.PasteSpecial (ppPastePicture)
oPPTFile.Slides(SlideNum).Select

方案说明 #

1. 使用Application.Union方法将多个非连续列区域合并为一个Range对象
2. 将合并后的区域复制并以值的形式粘贴到工作表的空白连续区域（示例中为AA1起始位置），得到连续的可操作区域
3. 再将该连续区域的内容粘贴到PowerPoint中

内容的提问来源于stack exchange，提问作者JvSitta