Kopieren Sie Tabellen aus verschiedenen Arbeitsblättern in Excel und fügen Sie sie in vorhandene Präsentation

Question

Ich habe eine spezielle Excel-Arbeitsmappe, die Tabellen in verschiedenen Arbeitsblättern in verschiedenen Bereich hat. Ich möchte Tabellen automatisch aus dem Arbeitsblatt meiner Excel-Arbeitsmappe kopiert werden und sollte eingefügt in verschiedene Folien meiner bestehenden PPT-Vorlage.

Ich habe einen Code, sondern geben Fehler auf Bereich erstellt, die ich kopieren möchten:

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

Ersetzen Sie Ihre For Each xlwksht In exworkb.Worksheets Schleife mit dem modifizierten unten Schleife.

ich die folgenden Änderungen an Ihrem Code gemacht (so wird es funktionieren):

1. Statt Selecting das Arbeitsblatt und dann ActiveSheet verwenden, verwenden xlwksht, habe ich die With xlwksht hinzugefügt.

2. Sie müssen nach der letzten Zeile und Spalte für jedes Arbeitsblatt suchen, also habe ich es innerhalb der With Anweisung verschoben.

3. Es ist nicht notwendig, die Folie Select jedes Mal, um zu kleben.

4. Einige andere Modifikationen ...

For-Schleife-Code Modified

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