如何将Excel多个单元格区域以图片形式粘贴至PowerPoint幻灯片？

原代码存在两个核心问题：一是把两个区域的图片先粘贴回Excel再传到PPT，冗余且只传了最后一张；二是每次新增幻灯片都插在第1位，会导致幻灯片顺序颠倒。以下是修正后的完整代码：

Dim PP As PowerPoint.Application
Dim PPpres As PowerPoint.Presentation
Dim PPslide As Object
Dim myShape As Object
Dim i As Integer
Dim k As Integer

' 初始化计数器
k = 1

' 打开指定PPT文件
Set PP = GetObject(, "PowerPoint.Application")
PP.Visible = True
Set PPpres = PP.Presentations.Open(Filename:="C:\Users\Mac\Desktop\test\PPT.pptx")

' 遍历目标列区域
For i = 6 To Cells(70, Columns.Count).End(xlToLeft).Column Step 10
    ' 在演示文稿末尾新增幻灯片（版式10为标题内容版式）
    Set PPslide = PPpres.Slides.Add(PPpres.Slides.Count + 1, 10)
    
    ' 处理第一个区域：Cells(70,i).Resize(1,10)
    Cells(70, i).Resize(1, 10).CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    DoEvents
    ' 粘贴到当前幻灯片
    PPslide.Shapes.PasteSpecial DataType:=2 ' 2 = ppPasteEnhancedMetafile
    Set myShape = PPslide.Shapes(PPslide.Shapes.Count)
    ' 设置位置和大小
    myShape.Left = 20
    myShape.Top = 180
    myShape.Height = 250
    myShape.Width = 950
    
    ' 处理第二个区域：单元格B1
    Range("B1").CopyPicture Appearance:=xlPrinter, Format:=xlPicture
    DoEvents
    ' 粘贴到当前幻灯片
    PPslide.Shapes.PasteSpecial DataType:=2
    Set myShape = PPslide.Shapes(PPslide.Shapes.Count)
    ' 设置B1图片的位置（可根据需求调整）
    myShape.Left = 20
    myShape.Top = 80 ' 放在第一个图片上方
    myShape.Height = 80
    myShape.Width = 300
    
    ' 命名PPT中的图片（可选）
    PPslide.Shapes(PPslide.Shapes.Count - 1).Name = "MainArea" & k
    PPslide.Shapes(PPslide.Shapes.Count).Name = "TitleB1" & k
    
    k = k + 1
    
    ' 清理剪贴板
    Application.CutCopyMode = False
Next i

' 激活PPT窗口
PP.Activate

' 释放对象
Set myShape = Nothing
Set PPslide = Nothing
Set PPpres = Nothing
Set PP = Nothing

关键修改说明 #

• 移除冗余步骤：删掉了原代码中把图片粘贴回Excel的操作，直接将Excel区域复制后粘贴到PPT，减少不必要的资源占用
• 双区域分别处理：对原目标区域和B1单元格分别执行复制、粘贴、位置设置流程，确保两个图片都能添加到同一张幻灯片
• 幻灯片新增逻辑优化：改为在演示文稿末尾添加幻灯片（PPpres.Slides.Count + 1），避免循环中幻灯片顺序颠倒
• 位置独立设置：为两个图片分别指定了不同的位置和大小，你可以根据实际排版需求调整Left、Top、Height、Width参数
• 对象释放：添加了对象释放代码，避免内存泄漏

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