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

Question

我有一个特定的 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

Answer 1

用下面修改过的循环替换你的For Each xlwksht In exworkb.Worksheets循环。

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

1. 我添加了With xlwksht，而不是Selecting 工作表，然后使用ActiveSheet，使用xlwksht。

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

3. 无需每次都Select幻灯片进行粘贴。

4. 其他一些修改...

修改后的 For 循环代码

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