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循环。

我对您的代码进行了以下修改（因此可以使用）：

使用Selecting代替ActiveSheet工作表，然后使用xlwksht，我添加了With xlwksht。
您需要搜索每个工作表的最后一行和列，因此我已将其移至With语句中。
每次粘贴都不需要Select幻灯片。
其他一些修改......

修改了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

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

1 个答案: