在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. 代替Selecting的工作表，然後使用ActiveSheet，使用xlwksht，我已經添加了With xlwksht。

2. 您需要搜索每個工作表的最後一行和列，因此我已將其移入With聲明中。

3. 有沒有必要Select滑動每次爲了粘貼。

4. 其他一些修改...

修改循環代碼

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