將Excel表格與指標複製到PowerPoint中的推薦方式

Question

我有一個帶有幾個圖表和附加儀表板（如圖所示）的Excel文件。

我複製從Excel圖表對象到PowerPoint，但不知道什麼是複製的附加儀表盤到PowerPoint的最佳途徑，因爲它包括一系列的Excel單元格中，一些指標使用條件格式化和一個圓形對象。

我不想將它複製爲圖片，因爲它看起來像在PowerPoint中失焦。

我已經添加了一段代碼（不是整件事情，因爲它很長），只是想知道複製這個儀表板圖像的方法。

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

您可以試試這裏顯示的示例示例。很多努力去適當地命名Excel工作表中完成的各種參數的範圍。我還展示了名稱管理器的快照，爲您提供一個想法以及PowerPoint中儀表板最終輸出的快照。

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