MHamid
11-01-2017, 08:13 PM
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 (file://\\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\ (file://\\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:
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
Thank you
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 (file://\\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\ (file://\\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:
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
Thank you