Vba 从excel中的不同工作表复制表格，并将其粘贴到现有演示文稿中

我有一个特定的excel工作簿，它在不同范围的不同工作表中有表格。我希望表格应自动从excel工作簿的所有工作表中复制，并粘贴到现有ppt模板的不同幻灯片中

我创建了一个代码，但在我要复制的范围上出现错误：

Sub newpp()
    Dim pptapp As PowerPoint.Application
    Dim pres As PowerPoint.Presentation
    Dim preslide As PowerPoint.Slide
    Dim shapepp As PowerPoint.Shape
    Dim exappli As Excel.Application
    Dim exworkb As Workbook
    Dim xlwksht As Worksheet
    Dim rng As Range
    Dim myshape As Object
    Dim mychart As ChartObject
    Dim lastrow1 As Long
    Dim lastcolumn1 As Long
    Dim slidecount As Long

    'Open powerpoint application
    Set exappli = New Excel.Application
    exappli.Visible = True

    'activate powerpoint application
    Set pptapp = New PowerPoint.Application
    pptapp.Visible = True
    pptapp.Activate

    'open the excel you wish to use
    Set exworkb = exappli.Workbooks.Open("C:\Users\ap\Desktop\Macro\Reference Sheet.xlsm")

    'open the presentation you wish to use
    Set pres = pptapp.Presentations.Open("C:\Users\ap\Desktop\Macro\new template.pptx")
    'Add title to the first slide
    With pres.Slides(1)
        If Not .Shapes.HasTitle Then
            Set shapepp = .Shapes.AddTitle
            Else: Set shapepp = .Shapes.Title
        End If
        With shapepp
            .TextFrame.TextRange.Text = "Gulf+ Market Segment Analysis Report" & vbNewLine & "P5 Week 04 FY17"
            .TextFrame.TextRange.Font.Name = "Arial Black"
            .TextFrame.TextRange.Font.Size = 24
            .TextEffect.FontBold = msoTrue
            .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignLeft
        End With
    End With
    'set the range

    lastrow1 = exworkb.ActiveSheet.Cells(Rows.Count, "A").End(xlUp).Row
    lastcolumn1 = exworkb.ActiveSheet.Cells(1, Columns.Count).End(xlToLeft).Column

    For Each xlwksht In exworkb.Worksheets
    xlwksht.Select Application.Wait(Now + TimeValue("0.00:1"))
    **'getting error in this line-------**
    exworkb.ActiveSheet.Range(Cells(1, 1), Cells(lastrow1, lastcolumn1)).CopyPicture appearance:=xlScreen, Format:=xlPicture

    slidecount = pres.Slides.Count

    Set preslide = pres.Slides.Add(slidecount + 1, 12)

    preslide.Select

    preslide.Shapes.Paste.Select

    pptapp.ActiveWindow.Selection.ShapeRange.Align msoAlignTops, msoTrue
    pptapp.ActiveWindow.Selection.ShapeRange.Top = 65
    pptapp.ActiveWindow.Selection.ShapeRange.Left = 72
    pptapp.ActiveWindow.Selection.ShapeRange.Width = 700

    Next xlwksht

End Sub

---

用下面修改过的循环替换exworkb.工作表中每个xlwksht的

我对您的代码进行了以下修改（因此可以正常工作）：

我没有选择工作表，然后使用
ActiveSheet
，而是使用
xlwksht
，而是使用xlwksht

添加了

您需要搜索每个工作表的最后一行和最后一列，因此我将其移动到
With
语句中

无需每次选择幻灯片进行粘贴

其他一些修改

为循环代码修改

For Each xlwksht In exworkb.Worksheets
    With xlwksht
        lastrow1 = .Cells(.Rows.Count, "A").End(xlUp).Row
        lastcolumn1 = .Cells(1, .Columns.Count).End(xlToLeft).Column

        ' set the range
        .Range(.Cells(1, 1), .Cells(lastrow1, lastcolumn1)).CopyPicture appearance:=xlScreen, Format:=xlPicture

        Set preslide = pres.Slides.Add(pres.Slides.Count + 1, 12) ' <-- set the Slide

        preslide.Shapes.Paste
        With preslide.Shapes(preslide.Shapes.Count) '<-- modify the pasted shape properties
            .Top = 65
            .Left = 72
            ' etc...
        End With

    End With
Next xlwksht

exworkb.工作表中每个xlwksht的

用xlwksht
lastrow1=.Cells（.Rows.Count，“A”）.End（xlUp）.Row
lastcolumn1=.Cells（1，.Columns.Count）.End（xlToLeft）.Column
“设定范围
.Range（.Cells（1，1），.Cells（lastrow1，lastcolumn1））.CopyPicture外观：=xlScreen，格式：=xlPicture
设置preslide=pres.Slides.Add（pres.Slides.Count+1,12）@a不客气，请标记为“答案”（单击我答案旁边的V）仅一个问题我正在PPT幻灯片上复制12个表格。目前，根据我指定的对齐代码，每个表都位于相同的位置。是否有一种方法可以为每个图表提供单独的对齐代码。例如幻灯片1右上角的第一张图表、幻灯片2中间的第二张图表、左上角的第三张图表等等……我已经点击了，您是否可以指导我回答上面提到的第二个问题。但是，对于
中的每个xlwksht，它不在这个
中。。。循环，您将需要手动修改每一个（这是许多代码行）感谢您的帮助是的，我会做单独的编码来对齐我的图表。我只想知道一件事，如果我想将它对齐到右上角，我们如何设置尺寸。是否有任何参考模块，您可以建议我从中学习对齐图表和表格，因为我想学习PPT中任何图形的对齐尺寸。例如，如果它说.Left=40，那是什么意思。