Recommended way of copying an Excel table with indicators to PowerPoint - vba

Question

I have an Excel file with a few charts and the attached dashboard (as can be seen in the image).
I am copying the charts objects from Excel to PowerPoint, but not sure what is the best way of copying the attached dashboard to PowerPoint, as it consists of a range of Excel cells, some Indicators using Conditional Formatting, and a circle object.
I don't want to copy it as a picture, because then it looks like it's out-of-focus in PowerPoint.
I have added a section of my code (not the whole thing as it's very long), just want to know the method of copying this dashboard image.
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

You can try with the sample example shown here. Lot of effort goes to properly naming the ranges for various parameters which is done in Excel worksheet. I have also shown a snapshot of the name manager to give you an idea and also the snapshot of final output of the dashboard in the 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