Empfohlene Methode zum Kopieren einer Excel-Tabelle mit Indikatoren zu PowerPoint

Question

Ich habe eine Excel-Datei mit ein paar Charts und dem beigefügten Dashboard (wie im Bild zu sehen).

Ich Kopiere die Charts Objekte aus Excel in Powerpoint, aber nicht sicher, was der beste Weg ist, das beigefügte Armaturenbrett zu Powerpoint zu kopieren, wie es aus einer Reihe von Excel-Zellen besteht, wobei einige Indikatoren Conditional Formatierung und ein Kreisobjekt.

Ich möchte es nicht als Bild kopieren, denn dann sieht es aus wie in PowerPoint unscharf ist.

Ich habe einen Abschnitt meines Codes hinzugefügt (nicht die ganze Sache, da es sehr lang ist), möchte nur die Methode des Kopierens dieses Dashboard-Bilds kennen.

Public Sub UpdatePowerPoint(PowerPointFile) 

'Add a reference to the Microsoft PowerPoint Library by: 
'1. Go to Tools in the VBA menu 
'2. Click on Reference 
'3. Scroll down to Microsoft PowerPoint X.0 Object Library, check the box, and press Okay 

Dim ppProgram       As PowerPoint.Application 
Dim ppPres        As PowerPoint.Presentation 
Dim ppFullPath       As String 
Dim ppName        As String 
Dim activeSlide       As PowerPoint.Slide 

Dim cht         As Excel.ChartObject 
Dim cht_count       As Integer 
Dim myShape        As Object 
Dim myChart        As Object 
Dim SlideNum, GPLRank     As Integer 
Dim ProjectIPPNum, ProjectName   As String 
Dim ShapeNum       As Integer 
Dim ExpenseActual, ExpenseBalance  As Long 

Dim StageStat       As String 
Dim nextKD        As String 
Dim shapeStageStat      As Shape 

On Error Resume Next 
Set ppProgram = GetObject(, "PowerPoint.Application") 
On Error GoTo 0 

ppFullPath = PowerPointFile 

If ppProgram Is Nothing Then 
    Set ppProgram = New PowerPoint.Application 
    i = 1 
Else 
    If ppProgram.Presentations.Count > 0 Then 
     ppName = Mid(ppFullPath, InStrRev(ppFullPath, "\") + 1, Len(ppFullPath)) 
     i = 1 
     ppCount = ppProgram.Presentations.Count 
     Do Until i = ppCount + 1 
      If ppProgram.Presentations.Item(i).Name = ppName Then 
       Set ppPres = ppProgram.Presentations.Item(i) 
       GoTo OnePager_Pres_Found 
      Else 
       i = i + 1 
      End If 
     Loop 
    End If 
End If 

ppProgram.Presentations.Open Filename:=PowerPointFile ' 'PowerPointFile = "C:\Test.pptx" 
Set ppPres = ppProgram.Presentations.Item(i) 

OnePager_Pres_Found: 
ppPres.Windows(1).Activate ' activate the One-Pager Presentation in case you have several open, and the One_pager is currently not the app "on-focus" 

' loop through all PowerPoint Slides, and copy all Chart objects from Excel 
For ProjectCounter = 0 To NumberofProjectShts 
    Worksheets(ProjectShtName(ProjectCounter)).Activate 

    GPLRank = ActiveSheet.Cells(12, 2) 
    SlideNum = ActiveSheet.Cells(24, 2) 
    ProjectIPPNum = ActiveSheet.Cells(2, 2) 
    ProjectName = ActiveSheet.Cells(3, 2) 
    StageStat = ActiveSheet.Cells(20, 2) 
    nextKD = ActiveSheet.Cells(18, 2) 
    ExpenseActual = ActiveSheet.Cells(33, 4) 
    ExpenseBalance = ActiveSheet.Cells(33, 5) 

    On Error GoTo Error_PPTSlideNum_Handler 
    ppProgram.ActivePresentation.Slides(SlideNum).Select 

    Set myShape = ppProgram.ActivePresentation.Slides(SlideNum).Shapes 

    ' --- loop throughout the Slide shapes and search for the Shape of type chart, then delete the old ones 
    For i = myShape.Count To 1 Step -1 
     If myShape.Item(i).HasChart Or myShape.Item(i).Type = msoEmbeddedOLEObject Or myShape.Item(i).Type = msoPicture Then 
      myShape.Item(i).Delete 
     Else 
      If myShape.Item(i).Left > 600 Then 
       myShape.Item(i).Delete 
      Else 
       Select Case myShape.Item(i).AutoShapeType 
        Case msoShapeOval, msoShapeOctagon, msoShapeIsoscelesTriangle 
         myShape.Item(i).Delete 
       End Select 
      End If 
     End If 
    Next 

    'Show the PowerPoint 
    ppProgram.Visible = True 

    ' select the 1-Pager Slide number which we will update the charts with the Excel Charts 
    Set activeSlide = ppProgram.ActivePresentation.Slides(SlideNum) 

    ' --- copy the dasboard (with Stage Status indicator) from Excel to Powerpoint , as Embedded Excel object --- 
    ' this is the part I've added to copy the dashboard from Excel to PowerPoint slide 
    Columns("F:G").ColumnWidth = 7.71 
    Columns("H:J").ColumnWidth = 4.71 
    Rows("1:4").RowHeight = 18.75 

    ActiveSheet.Range("F1:J4").Copy ' .Select 

    ' Paste to PowerPoint and position 
    Set myShape = ppProgram.ActivePresentation.Slides(SlideNum).Shapes.PasteSpecial(ppPasteMetafilePicture, msoFalse) 
    ' Set Dashboard object properties: 
    myShape.Left = 536 ' 7.44" 
    myShape.Top = 7 ' 0.1" 

    ' --- Loop through each chart in the Excel worksheet and paste them into the PowerPoint --- 
    For Each cht In ActiveSheet.ChartObjects 
     'go to the 1-Pager Slide number where we will update the charts with the Excel Charts 
     Set activeSlide = ppProgram.ActivePresentation.Slides(SlideNum) 

     'Copy the chart and paste it into the PowerPoint as a Metafile Picture 
     cht.Select 
     ActiveChart.ChartArea.Copy 

     If cht.Name = "RiskRadar_Chart" Then ' change paste setting only for Radar type chart, to look nicer in PowerPoint 
      Set myChart = ppProgram.ActivePresentation.Slides(SlideNum).Shapes.PasteSpecial(ppPasteMetafilePicture, msoFalse) 
     Else 
      Set myChart = ppProgram.ActivePresentation.Slides(SlideNum).Shapes.PasteSpecial(ppPasteDefault, msoFalse) 'ppPasteShape 
     End If 

     'Adjust the positioning of the Chart on Powerpoint Slide , each inch is 72 points 
     Select Case cht.Name 
      Case "Timeline_Chart" ' 1 ' Timeline Chart 
       myChart.Left = 11 ' 0.16" 
       myChart.Top = 403 ' 5.55" 

      Case "Budget_Chart" ' 2 ' Man-Hours Chart 
       myChart.Left = 387 ' 5.37" 
       myChart.Top = 284 ' 3.94" 

      Case "Expense_Chart" ' 3 ' Expense Chart 
       myChart.Left = 387 ' 5.37" 
       myChart.Top = 347 ' 4.81" 

      Case "RiskRadar_Chart" ' 4 ' Risk-Radar Chart 
       myChart.Left = 449 ' 6.23" 
       myChart.Top = 7 ' 0.1" 

     End Select 
    Next 

    ' --- Add Stage Status indicator with Next KD text inside (except PARK) ---- 
    Select Case StageStat 
     Case "Green" 
      With activeSlide.Shapes.AddShape(msoShapeOval, 652, 16, 32, 32) ' Left, Top , Width ,Height 
       .Fill.ForeColor.RGB = RGB(0, 128, 0) ' color Green 
       .Fill.Solid 
       .Line.ForeColor.ObjectThemeColor = msoThemeColorText1 
       .Line.Weight = 0.75 

       .TextFrame.TextRange.Font.color.RGB = RGB(0, 0, 0) ' Shape Text Color 
       .TextFrame.TextRange.Characters.Text = nextKD ' Text inside Shape 
       .TextFrame2.TextRange.Font.Size = 14 ' Adjust Font Size 
       .TextFrame2.TextRange.Font.Name = "Arial" ' Adjust Font Style 
       .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter ' Center Align Text 
       .TextFrame2.VerticalAnchor = msoAnchorMiddle ' Vertically Align Text to Middle 
       .TextFrame2.MarginLeft = 0 
       .TextFrame2.MarginRight = 0 
      End With 

     Case "Yellow" 
      With activeSlide.Shapes.AddShape(msoShapeRectangle, 652, 16, 32, 32) ' Left, Top , Width ,Height 
       .Fill.ForeColor.RGB = RGB(255, 255, 0) ' color Yellow 
       .Fill.Solid 
       .Line.ForeColor.ObjectThemeColor = msoThemeColorText1 
       .Line.Weight = 0.75 

       .TextFrame.TextRange.Font.color.RGB = RGB(0, 0, 0) ' Shape Text Color 
       .TextFrame.TextRange.Characters.Text = nextKD ' Text inside Shape 
       .TextFrame2.TextRange.Font.Size = 14 ' Adjust Font Size 
       .TextFrame2.TextRange.Font.Name = "Arial" ' Adjust Font Style 
       .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter ' Center Align Text 
       .TextFrame2.VerticalAnchor = msoAnchorMiddle ' Vertically Align Text to Middle 
       .TextFrame2.MarginLeft = 0 
       .TextFrame2.MarginRight = 0 
      End With 

     Case "Red" 
      With activeSlide.Shapes.AddShape(msoShapeIsoscelesTriangle, 652, 16, 36, 36) ' Left, Top , Width ,Height 
       .Fill.ForeColor.RGB = RGB(255, 0, 0) ' color Red 
       .Fill.Solid 
       .Line.ForeColor.ObjectThemeColor = msoThemeColorText1 
       .Line.Weight = 0.75 

       .TextFrame.TextRange.Font.color.RGB = RGB(0, 0, 0) ' Shape Text Color 
       .TextFrame.TextRange.Characters.Text = nextKD ' Text inside Shape 
       .TextFrame2.TextRange.Font.Size = 14 ' Adjust Font Size 
       .TextFrame2.TextRange.Font.Name = "Arial" ' Adjust Font Style 
       .TextFrame.TextRange.Paragraphs.ParagraphFormat.Alignment = ppAlignCenter ' Center Align Text 
       .TextFrame2.VerticalAnchor = msoAnchorMiddle ' Vertically Align Text to Middle 
       .TextFrame2.MarginLeft = 0 
       .TextFrame2.MarginRight = 0 
       .TextFrame2.Column.Number = 2 
      End With 
    End Select 

Error_PPTSlideNum_Handler: 
If Err.Number <> 0 Then 
    Err.Clear 
    MsgBox "Project " & ProjectName & " Slide Number " & SlideNum & " not found in selected PowerPoint. " & _ 
      vbCrLf & "Update your Slide Number according to it's position.", vbInformation, "PowerPoint Slide Number Error" 
End If 

Next ' ProjectCounter = 0 To NumberofProjectShts 

AppActivate ("Microsoft PowerPoint") 
Set activeSlide = Nothing 
Set ppProgram = Nothing 
Set ppPres = Nothing 

End Sub 

Answer 1

Sie können mit der Probe hier gezeigten Beispiel versuchen. Viel Aufwand geht, um die Bereiche für verschiedene Parameter richtig zu benennen, die in Excel-Arbeitsblatt getan wird. Ich habe auch eine Momentaufnahme des Namens-Managers gezeigt, um Ihnen eine Idee und auch den Schnappschuss der endgültigen Ausgabe des Dashboards in PowerPoint zu geben.

Option Explicit 

Dim PP As Object 
Dim PP_File As Object 
Dim PP_Slide As Object 

Private Sub CopyandPastetoPPT(myRangeName As String, myTitle As String, myScaleHeight As Single, myScaleWidth As Single) 
Dim NextShape As Integer 
Dim ReportDate As String 

    ReportDate = Range("myReportDate").Value & "/Week " & Range("myReportWeek").Value & " - " 
    Application.GoTo Reference:=myRangeName 
    Selection.CopyPicture Appearance:=xlScreen, Format:=xlPicture 
    Range("A1").Select 
    PP.ActivePresentation.Slides.Add PP.ActivePresentation.Slides.Count + 1, 11 
    Set PP_Slide = PP_File.Slides(PP.ActivePresentation.Slides.Count) 
    PP_Slide.Shapes.Title.TextFrame.TextRange.Text = ReportDate & myTitle 
    NextShape = PP_Slide.Shapes.Count + 1 
    PP_Slide.Shapes.PasteSpecial 2 
    PP_Slide.Shapes(NextShape).ScaleHeight myScaleHeight, 1 
    PP_Slide.Shapes(NextShape).ScaleWidth myScaleWidth, 1 
    PP_Slide.Shapes(NextShape).Left = PP_File.PageSetup.SlideWidth \ 2 - PP_Slide.Shapes(NextShape).Width \ 2 
    PP_Slide.Shapes(NextShape).Top = 90 
End Sub 



Sub ExportToPPT() 
Dim ActFileName As Variant 
Dim ScaleFactor As Single 

    On Error GoTo ErrorHandling 
    ActFileName = Application.GetOpenFilename("Microsoft PowerPoint-Files (*.ppt), *.ppt") 
    ScaleFactor = Range("myScaleFactor").Value 
    Set PP = CreateObject("Powerpoint.Application") 
    If ActFileName = False Then 
     PP.Activate 
     PP.Presentations.Add 
     Set PP_File = PP.ActivePresentation 
    Else 
     PP.Activate 
     Set PP_File = PP.Presentations.Open(ActFileName) 
    End If 
    PP.Visible = True 
    CopyandPastetoPPT "myDashboard01", Range("myInputStartTitles").Offset(1, 0).Value, ScaleFactor, ScaleFactor 

    Set PP_Slide = Nothing 
    Set PP_File = Nothing 
    Set PP = Nothing 
    Worksheets(1).Activate 
    Exit Sub 

ErrorHandling: 

    Set PP_Slide = Nothing 
    Set PP_File = Nothing 
    Set PP = Nothing 
    MsgBox "Error No.: " & Err.Number & vbNewLine & vbNewLine & "Description: " & Err.Description, vbCritical, "Error" 

End Sub