hello
I need some help with a vba code that will copy various charts from 1 excel worksheet into 1 powerpoint slide. I know this is possible, but for some reason I cannot make heads or tails with various codes I've found online.
This is my situation. I have an excel workbook with 16 spreadsheets. However, I only need the vba code to look at 6 of these spreadsheets only. Each spreadsheet has 9 charts that will need to be copied from excel and pasted into 1 slide. So 6 excel worksheets with 9 charts in each copied into 6 pre-existing powerpoint slides ... 9 charts into each slide. For example, there is 1 worksheet labeled "Global" in Excel. The 9 charts located into this worksheet will need to be copied and pasted as a picture into the powerpoint slide labeled "Global".
If anyone sees any other errors in my code, please let me know as well.
Below is my full code:
Option Explicit '//-----------------------------------------------------------------------------------// ' [/b] PptCreator [/b] ' ' - Purpose: Create EMR Powerpoint ' ' [/u] Process Steps [/u] ' - ' - ' - ' - ' - '//-----------------------------------------------------------------------------------// 'Declaring Constants Const sTemplate As String = "\\Naeast.ad.jpmorganchase.com\amercorp$\CORPRE\NARESHARE04\CORP_SEC\METRICS\Reporting\Quality\EMRs\1-Template\Global EMR - Template.pptx" Const sFinalP As String = "\\Naeast.ad.jpmorganchase.com\amercorp$\CORPRE\NARESHARE04\CORP_SEC\METRICS\Reporting\Quality\EMRs\" 'Declaring Helper Variables Dim aExcel As Excel.Application Dim wb As Workbook, ws As Worksheet, wsfn As Excel.WorksheetFunction Dim sDate As String 'Decalring Powerpoint Helpers Dim aPPT As PowerPoint.Application Dim pptPres As PowerPoint.Presentation Dim pptSlide As PowerPoint.Slide, pptSlides As PowerPoint.Slides Dim pptShape As PowerPoint.Shape 'Dictionary Helper Dim key As Variant Private Function GetFinal(s As String) As String 'Declare Helpers Dim fso As Scripting.FileSystemObject Dim fsoFile As Scripting.File Dim fsoFolder As Scripting.Folder Dim dtmLast As Date Dim sLast As String Set fso = New Scripting.FileSystemObject Set fsoFolder = fso.GetFolder(s) 'Get Most Recent Publication For Each fsoFile In fsoFolder.Files Select Case True Case (fsoFile.DateLastModified > dtmLast) And (fsoFile.Name Like "*Global DDO EMR*.xlsx") sLast = fsoFile.Path dtmLast = fsoFile.DateLastModified End Select Next fsoFile '/Set Function GetFinal = sLast End Function Sub PptCreator() '/Setting Variables Set aExcel = Excel.Application Set wsfn = Excel.WorksheetFunction '/PowerPoint On Error Resume Next Set aPPT = PowerPoint.Application If aPPT Is Nothing Then Set aPPT = New PowerPoint.Application aPPT.Visible = msoTrue aPPT.Activate On Error GoTo 0 OptiMode CreatePPT SavePPT RegMode End Sub Private Sub CreatePPT() 'Helper Variables Dim nCounter As Integer Dim chtob As ChartObject Dim i As Long, total_slide i = 1 '/Set Variables Set wb = Workbooks.Open(Filename:=GetFinal(sFinalP), ReadOnly:=False) '/Powerpoint Operations Set pptPres = aPPT.Presentations.Open(sTemplate) 'shts = ("Macro Sheet,Summary % Change,Summary Net Change,Region Reference,CIB,GIM,CB,WMIS,Raw Data,Re ference") total_slide = pptPres.Slides.Count '/Create Powerpoint For Each ws In wb.Sheets ws.Select For Each chtob In ActiveSheet.ChartObjects chtob.Copy Set pptSlide = pptPres.Slides(i) pptSlide.Shapes.PasteSpecial ppPasteShape i = i + 1 If i > total_slide Then Exit Sub Next Next '/Create Powerpoint 'For Each ws In wb.Sheets ' With ws 'Select Case True ' Case (.Name <> "Macro Sheet") And (.Name <> "Summary % Change") And (.Name <> "Summary Net Change") And (.Name <> "Region Reference") And (.Name <> "CIB") And (.Name <> "GIM") And (.Name <> "CB") And (.Name <> "WMIS") And (.Name <> "Raw Data") And (.Name <> "Reference") 'If InStr(1, shts & ",", ws.CodeName & ",", vbTextCompare) = 0 Then ' If ws.Name <> "Macro Sheet" And ws.Name <> "Summary % Change" And ws.Name <> "Summary Net Change" And ws.Name <> "Region Reference" And ws.Name <> "CIB" And ws.Name <> "GIM" And ws.Name <> "CB" And ws.Name <> "WMIS" And ws.Name <> "Raw Data" And ws.Name <> "Reference" Then 'Do 'nCounter = nCounter + 1 'Set Range 'Copy Chart ' For Each chtob In ActiveSheet.ChartObjects ' chtob.Chart.ChartArea.Copy 'Set Powerpoint Slide ' Set pptSlide = pptPres.Slides(SlideDic(.Name, nCounter)) 'Paste Chart ' pptSlide.Shapes.Paste 'Clear Clipboard ' aExcel.CutCopyMode = False 'End If 'End Select ' End With ' nCounter = 0 'Next ws End Sub Private Sub SavePPT() 'Helpers Dim dtmDate As Date, dtmLastWeek '/Save New Presentation 'Select Case Weekday(Date, vbSunday) ' Case Is <> 4 ' dtmDate = Date - (Weekday(Date, vbSunday) - 4) ' dtmLastWeek = dtmDate 'End Select With pptPres .SaveAs sFinalP & "Global EMR - " & Format(dte, "mmmm yyyy") & ".pptx", ppSaveAsPresentation .Close End With aPPT.Quit aExcel.DisplayAlerts = False With wb .Close SaveChanges:=False End With aExcel.DisplayAlerts = True End Sub Private Function SlideDic(sName As String, num As Integer) As Integer '/Case Switcher Select Case sName Case Is = "Global" ' Select Case num ' Case 1 SlideDic = 0 End Select Case Is = "APAC" SlideDic = 1 Case Is = "North America" SlideDic = 2 Case Is = "Latin America" SlideDic = 3 Case Is = "Bournemouth" SlideDic = 4 Case Is = "Geneva" SlideDic = 5 End Select End Function Private Function SizePosDic(sName As String, num As Integer) As Variant 'Helpers Const n As Integer = 72 '/Case Switcher Select Case sName Case Is = "Global" Select Case num Case 1 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 2 * n) Case 2 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 3.93 * n) Case 3 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 6 * n) Case 4 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 2 * n) Case 5 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 3.93 * n) Case 6 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 6 * n) Case 7 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 2 * n) Case 8 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 3.93 * n) Case 9 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 6 * n) End Select Case Is = "APAC" Select Case num Case 1 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 2 * n) Case 2 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 3.93 * n) Case 3 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 6 * n) Case 4 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 2 * n) Case 5 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 3.93 * n) Case 6 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 6 * n) Case 7 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 2 * n) Case 8 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 3.93 * n) Case 9 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 6 * n) End Select Case Is = "North America" Select Case num Case 1 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 2 * n) Case 2 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 3.93 * n) Case 3 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 6 * n) Case 4 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 2 * n) Case 5 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 3.93 * n) Case 6 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 6 * n) Case 7 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 2 * n) Case 8 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 3.93 * n) Case 9 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 6 * n) End Select Case Is = "Latin America" Select Case num Case 1 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 2 * n) Case 2 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 3.93 * n) Case 3 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 6 * n) Case 4 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 2 * n) Case 5 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 3.93 * n) Case 6 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 6 * n) Case 7 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 2 * n) Case 8 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 3.93 * n) Case 9 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 6 * n) End Select Case Is = "Bournemouth" Select Case num Case 1 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 2 * n) Case 2 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 3.93 * n) Case 3 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 6 * n) Case 4 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 2 * n) Case 5 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 3.93 * n) Case 6 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 6 * n) Case 7 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 2 * n) Case 8 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 3.93 * n) Case 9 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 6 * n) End Select Case Is = "Geneva" Select Case num Case 1 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 2 * n) Case 2 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 3.93 * n) Case 3 SizePosDic = Array(2 * n, 3.2 * n, 0.85 * n, 6 * n) Case 4 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 2 * n) Case 5 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 3.93 * n) Case 6 SizePosDic = Array(2 * n, 3.2 * n, 4.1 * n, 6 * n) Case 7 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 2 * n) Case 8 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 3.93 * n) Case 9 SizePosDic = Array(2 * n, 3.2 * n, 7.35 * n, 6 * n) End Select End Select End Function Private Sub OptiMode() 'Speed Optimization If aExcel Is Nothing Then Set aExcel = Excel.Application On Error Resume Next With aExcel .DisplayStatusBar = False .EnableEvents = False .ScreenUpdating = False .Calculation = xlCalculationManual End With On Error GoTo 0 End Sub Private Sub RegMode() 'Regular Operation If aExcel Is Nothing Then Set aExcel = Excel.Application On Error Resume Next With aExcel .DisplayStatusBar = True .EnableEvents = True .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With On Error GoTo 0 End Sub
This is part of the code that I can't seem to figure out:
Thank youPrivate Sub CreatePPT() 'Helper Variables Dim nCounter As Integer Dim chtob As ChartObject Dim i As Long, total_slide i = 1 '/Set Variables Set wb = Workbooks.Open(Filename:=GetFinal(sFinalP), ReadOnly:=False) '/Powerpoint Operations Set pptPres = aPPT.Presentations.Open(sTemplate) 'shts = ("Macro Sheet,Summary % Change,Summary Net Change,Region Reference,CIB,GIM,CB,WMIS,Raw Data,Re ference") total_slide = pptPres.Slides.Count '/Create Powerpoint For Each ws In wb.Sheets ws.Select For Each chtob In ActiveSheet.ChartObjects chtob.Copy Set pptSlide = pptPres.Slides(i) pptSlide.Shapes.PasteSpecial ppPasteShape i = i + 1 If i > total_slide Then Exit Sub Next Next '/Create Powerpoint 'For Each ws In wb.Sheets ' With ws 'Select Case True ' Case (.Name <> "Macro Sheet") And (.Name <> "Summary % Change") And (.Name <> "Summary Net Change") And (.Name <> "Region Reference") And (.Name <> "CIB") And (.Name <> "GIM") And (.Name <> "CB") And (.Name <> "WMIS") And (.Name <> "Raw Data") And (.Name <> "Reference") 'If InStr(1, shts & ",", ws.CodeName & ",", vbTextCompare) = 0 Then ' If ws.Name <> "Macro Sheet" And ws.Name <> "Summary % Change" And ws.Name <> "Summary Net Change" And ws.Name <> "Region Reference" And ws.Name <> "CIB" And ws.Name <> "GIM" And ws.Name <> "CB" And ws.Name <> "WMIS" And ws.Name <> "Raw Data" And ws.Name <> "Reference" Then 'Do 'nCounter = nCounter + 1 'Set Range 'Copy Chart ' For Each chtob In ActiveSheet.ChartObjects ' chtob.Chart.ChartArea.Copy 'Set Powerpoint Slide ' Set pptSlide = pptPres.Slides(SlideDic(.Name, nCounter)) 'Paste Chart ' pptSlide.Shapes.Paste 'Clear Clipboard ' aExcel.CutCopyMode = False 'End If 'End Select ' End With ' nCounter = 0 'Next ws End Sub
Reply With Quote
