Create a New Slide
Sub NewSlide()
ActivePresentation.Slides.Add 1, ppLayoutTitle
End Sub
Insert Current Date & Time on Slide
Sub InsertDate()
ActiveWindow.Selection.SlideRange.Shapes.AddTextbox(1, 50, 50, 200, 50).TextFrame.TextRange.text = Now
End Sub
Copy charts from Excel file to PowerPoint file
Option Explicit
Option Base 1
Public fd As Office.FileDialog
Public strFile As String
Public folderPath As String
Public filePath(5) As String
Public folderName(5) As String
Public wb As Workbook
Public pptApp As Object
Public pptPres As Object
Sub Final()
'######################################################################################################
' Open folder & files
' This procedure will open PowerPoint file & select folder of Excel output files.
'######################################################################################################
Application.DisplayAlerts = False
Dim pptApp As Object
Dim i As Byte
filePath(1) = "1. AR.xlsb"
filePath(2) = "2. Other Information.xlsb"
filePath(3) = "3. IS and BS.xlsb"
filePath(4) = "4. Cash Flow.xlsb"
filePath(5) = "5. Cash Balance.xlsb"
folderName(1) = "\RTC Asia Pacific\"
folderName(2) = "\RTC North Europe, Central Asia & Middle East\"
folderName(3) = "\RTC South Europe Africa & Latin America\"
folderName(4) = "\RTC USA & Canada\"
folderName(5) = "\UnAllocated Entities\"
'open file dialog box
strFile = ""
Call OpenFileDialog
If strFile = "" Then
Exit Sub
Else
' Create a new PowerPoint application instance
Set pptApp = CreateObject("PowerPoint.Application")
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
' Make PowerPoint visible
pptApp.Visible = True
End If
'open folder dialog box
Call SelectFolderDialog
If folderPath = "" Then
Exit Sub
Else
On Error Resume Next
For i = 1 To 5
If i = 1 Then
'open excel file
Call RTC_Asia_Pacific_AR_File
Call RTC_Asia_Pacific_Other_Information_File
Call RTC_Asia_Pacific_IS_and_BS_File
Call RTC_Asia_Pacific_Cash_Flow_File
Call RTC_Asia_Pacific_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(1) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
ElseIf i = 2 Then
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
'open excel file
Call RTC_North_Europe_AR_File
Call RTC_North_Europe_Other_Information_File
Call RTC_North_Europe_IS_and_BS_File
Call RTC_North_Europe_Cash_Flow_File
Call RTC_North_Europe_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(2) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
ElseIf i = 3 Then
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
'open excel file
Call RTC_South_Europe_AR_File
Call RTC_South_Europe_Other_Information_File
Call RTC_South_Europe_IS_and_BS_File
Call RTC_South_Europe_Cash_Flow_File
Call RTC_South_Europe_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(3) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
ElseIf i = 4 Then
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
'open excel file
Call RTC_USA_AR_File
Call RTC_USA_Other_Information_File
Call RTC_USA_IS_and_BS_File
Call RTC_USA_Cash_Flow_File
Call RTC_USA_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(4) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
ElseIf i = 5 Then
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
'open excel file
Call RTC_UnAllocated_AR_File
Call RTC_UnAllocated_Other_Information_File
Call RTC_UnAllocated_IS_and_BS_File
Call RTC_UnAllocated_Cash_Flow_File
Call RTC_UnAllocated_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(5) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
End If
Next i
On Error GoTo 0
End If
Application.StatusBar = ""
Application.DisplayAlerts = True
End Sub
Sub OpenFileDialog()
'######################################################################################################
' Open file dialog box
'This procedure will prompt open file dialog box and user can choose input file.
'######################################################################################################
Dim uName As String
Set fd = Application.FileDialog(msoFileDialogFilePicker)
With fd
.Filters.Clear
.Filters.Add "PowerPoint Files", "*.ppt*", 1
.Filters.Add "All Files", "*.*", 2
.Title = "Choose an PowerPoint file"
.InitialFileName = "C:\Users\username\OneDrive\My Documents\Projects\2024\TGP_Excel To PPT\File.pptx"
.AllowMultiSelect = False
'get user signum/name
uName = Environ$("UserName")
If uName = "" Then
uName = Mid(WorksheetFunction.Substitute((Environ$("UserProfile")), "\", "_", 2), WorksheetFunction.Find("_", WorksheetFunction.Substitute((Environ$("UserProfile")), "\", "_", 2)) + 1, 8)
End If
.InitialFileName = "C:\Users\" & uName & "\Downloads"
If .Show = True Then
strFile = .SelectedItems(1)
End If
End With
End Sub
Sub SelectFolderDialog()
'######################################################################################################
' Open folder dialog box
'This procedure will prompt open folder dialog box and user can choose input folder.
'######################################################################################################
Dim fd As FileDialog
' Create a FileDialog object as a Folder Picker dialog box
Set fd = Application.FileDialog(msoFileDialogFolderPicker)
' Set the title of the dialog box
fd.Title = "Select a Folder"
' Show the dialog box
If fd.Show = -1 Then ' If the user makes a selection
folderPath = fd.SelectedItems(1) ' Get the folder path
Else
End If
' Clean up
Set fd = Nothing
End Sub
Sub RTC_Asia()
'######################################################################################################
' Open folder & files
' This procedure will open PowerPoint file & select folder of Excel output files.
'######################################################################################################
Application.DisplayAlerts = False
Dim pptApp As Object
Dim i As Byte
filePath(1) = "1. AR.xlsb"
filePath(2) = "2. Other Information.xlsb"
filePath(3) = "3. IS and BS.xlsb"
filePath(4) = "4. Cash Flow.xlsb"
filePath(5) = "5. Cash Balance.xlsb"
folderName(1) = "\RTC Asia Pacific\"
folderName(2) = "\RTC North Europe, Central Asia & Middle East\"
folderName(3) = "\RTC South Europe Africa & Latin America\"
folderName(4) = "\RTC USA & Canada\"
folderName(5) = "\UnAllocated Entities\"
'open file dialog box
strFile = ""
Call OpenFileDialog
If strFile = "" Then
Exit Sub
Else
' Create a new PowerPoint application instance
Set pptApp = CreateObject("PowerPoint.Application")
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
' Make PowerPoint visible
pptApp.Visible = True
End If
'open folder dialog box
Call SelectFolderDialog
If folderPath = "" Then
Exit Sub
Else
On Error Resume Next
'open excel file
Call RTC_Asia_Pacific_AR_File
Call RTC_Asia_Pacific_Other_Information_File
Call RTC_Asia_Pacific_IS_and_BS_File
Call RTC_Asia_Pacific_Cash_Flow_File
Call RTC_Asia_Pacific_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(1) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
On Error GoTo 0
End If
Application.StatusBar = ""
Application.DisplayAlerts = True
End Sub
Sub RTC_North_Europe()
'######################################################################################################
' Open folder & files
' This procedure will open PowerPoint file & select folder of Excel output files.
'######################################################################################################
Application.DisplayAlerts = False
Dim pptApp As Object
Dim i As Byte
filePath(1) = "1. AR.xlsb"
filePath(2) = "2. Other Information.xlsb"
filePath(3) = "3. IS and BS.xlsb"
filePath(4) = "4. Cash Flow.xlsb"
filePath(5) = "5. Cash Balance.xlsb"
folderName(1) = "\RTC Asia Pacific\"
folderName(2) = "\RTC North Europe, Central Asia & Middle East\"
folderName(3) = "\RTC South Europe Africa & Latin America\"
folderName(4) = "\RTC USA & Canada\"
folderName(5) = "\UnAllocated Entities\"
'open file dialog box
strFile = ""
Call OpenFileDialog
If strFile = "" Then
Exit Sub
Else
' Create a new PowerPoint application instance
Set pptApp = CreateObject("PowerPoint.Application")
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
' Make PowerPoint visible
pptApp.Visible = True
End If
'open folder dialog box
Call SelectFolderDialog
If folderPath = "" Then
Exit Sub
Else
On Error Resume Next
'open excel file
Call RTC_North_Europe_AR_File
Call RTC_North_Europe_Other_Information_File
Call RTC_North_Europe_IS_and_BS_File
Call RTC_North_Europe_Cash_Flow_File
Call RTC_North_Europe_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(2) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
On Error GoTo 0
End If
Application.StatusBar = ""
Application.DisplayAlerts = True
End Sub
Sub RTC_South_Europe()
'######################################################################################################
' Open folder & files
' This procedure will open PowerPoint file & select folder of Excel output files.
'######################################################################################################
Application.DisplayAlerts = False
Dim pptApp As Object
Dim i As Byte
filePath(1) = "1. AR.xlsb"
filePath(2) = "2. Other Information.xlsb"
filePath(3) = "3. IS and BS.xlsb"
filePath(4) = "4. Cash Flow.xlsb"
filePath(5) = "5. Cash Balance.xlsb"
folderName(1) = "\RTC Asia Pacific\"
folderName(2) = "\RTC North Europe, Central Asia & Middle East\"
folderName(3) = "\RTC South Europe Africa & Latin America\"
folderName(4) = "\RTC USA & Canada\"
folderName(5) = "\UnAllocated Entities\"
'open file dialog box
strFile = ""
Call OpenFileDialog
If strFile = "" Then
Exit Sub
Else
' Create a new PowerPoint application instance
Set pptApp = CreateObject("PowerPoint.Application")
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
' Make PowerPoint visible
pptApp.Visible = True
End If
'open folder dialog box
Call SelectFolderDialog
If folderPath = "" Then
Exit Sub
Else
On Error Resume Next
'open excel file
Call RTC_South_Europe_AR_File
Call RTC_South_Europe_Other_Information_File
Call RTC_South_Europe_IS_and_BS_File
Call RTC_South_Europe_Cash_Flow_File
Call RTC_South_Europe_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(3) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
On Error GoTo 0
End If
Application.StatusBar = ""
Application.DisplayAlerts = True
End Sub
Sub RTC_USA()
'######################################################################################################
' Open folder & files
' This procedure will open PowerPoint file & select folder of Excel output files.
'######################################################################################################
Application.DisplayAlerts = False
Dim pptApp As Object
Dim i As Byte
filePath(1) = "1. AR.xlsb"
filePath(2) = "2. Other Information.xlsb"
filePath(3) = "3. IS and BS.xlsb"
filePath(4) = "4. Cash Flow.xlsb"
filePath(5) = "5. Cash Balance.xlsb"
folderName(1) = "\RTC Asia Pacific\"
folderName(2) = "\RTC North Europe, Central Asia & Middle East\"
folderName(3) = "\RTC South Europe Africa & Latin America\"
folderName(4) = "\RTC USA & Canada\"
folderName(5) = "\UnAllocated Entities\"
'open file dialog box
strFile = ""
Call OpenFileDialog
If strFile = "" Then
Exit Sub
Else
' Create a new PowerPoint application instance
Set pptApp = CreateObject("PowerPoint.Application")
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
' Make PowerPoint visible
pptApp.Visible = True
End If
'open folder dialog box
Call SelectFolderDialog
If folderPath = "" Then
Exit Sub
Else
On Error Resume Next
'open excel file
Call RTC_USA_AR_File
Call RTC_USA_Other_Information_File
Call RTC_USA_IS_and_BS_File
Call RTC_USA_Cash_Flow_File
Call RTC_USA_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(4) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
On Error GoTo 0
End If
Application.StatusBar = ""
Application.DisplayAlerts = True
End Sub
Sub RTC_UnAllocated()
'######################################################################################################
' Open folder & files
' This procedure will open PowerPoint file & select folder of Excel output files.
'######################################################################################################
Application.DisplayAlerts = False
Dim pptApp As Object
Dim i As Byte
filePath(1) = "1. AR.xlsb"
filePath(2) = "2. Other Information.xlsb"
filePath(3) = "3. IS and BS.xlsb"
filePath(4) = "4. Cash Flow.xlsb"
filePath(5) = "5. Cash Balance.xlsb"
folderName(1) = "\RTC Asia Pacific\"
folderName(2) = "\RTC North Europe, Central Asia & Middle East\"
folderName(3) = "\RTC South Europe Africa & Latin America\"
folderName(4) = "\RTC USA & Canada\"
folderName(5) = "\UnAllocated Entities\"
'open file dialog box
strFile = ""
Call OpenFileDialog
If strFile = "" Then
Exit Sub
Else
' Create a new PowerPoint application instance
Set pptApp = CreateObject("PowerPoint.Application")
' Open the PowerPoint file
Set pptPres = pptApp.Presentations.Open(strFile)
' Make PowerPoint visible
pptApp.Visible = True
End If
'open folder dialog box
Call SelectFolderDialog
If folderPath = "" Then
Exit Sub
Else
On Error Resume Next
'open excel file
Call RTC_UnAllocated_AR_File
Call RTC_UnAllocated_Other_Information_File
Call RTC_UnAllocated_IS_and_BS_File
Call RTC_UnAllocated_Cash_Flow_File
Call RTC_UnAllocated_Cash_Balance_File
pptPres.SaveAs folderPath & folderName(5) & "TGP.pptx"
DoEvents
pptPres.Close
DoEvents
On Error GoTo 0
End If
Application.StatusBar = ""
Application.DisplayAlerts = True
End Sub
Sub RTC_Asia_Pacific_AR_File()
'######################################################################################################
' Open AR file
'This procedure will open AR file, copy & paste charts into ppt file.
'######################################################################################################
Dim ws As Worksheet
Dim chart As ChartObject
Dim pptSlide As Object
Dim i As Byte
Dim pptShape As Object
'filePath = "1. AR.xlsb"
Application.StatusBar = folderName(1) & filePath(1)
Set wb = Workbooks.Open(Filename:=folderPath & folderName(1) & filePath(1), ReadOnly:=True)
Set ws = wb.Worksheets("Output")
'slide 14
With ws
.Activate
'------------------------------------- External start -----------------------------------------------
'chart1 - External AR Total
' Select the chart from the Excel worksheet
Set chart = .ChartObjects("Chart 1")
' Copy the chart as a picture
chart.chart.ChartArea.Copy
' Select the slide
Set pptSlide = pptPres.Slides(14)
' Paste the chart into the PowerPoint slide and get the reference to the pasted shape
Set pptShape = pptSlide.Shapes.PasteSpecial(DataType:=2)(1) ' 2 represents ppPasteEnhancedMetafile
Application.CutCopyMode = False
' Set the size and position of the pasted shape
With pptShape
.LockAspectRatio = msoFalse
.Height = 8.75 * 28.35 ' Set the desired Height in cm
.Width = 15.28 * 28.35 ' Set the desired width in cm
.Left = 1.33 * 28.35 ' Set the desired width in cm
.Top = 3.53 * 28.35 ' Set the desired width in cm
End With
'chart1 - External AR Due
' Select the chart from the Excel worksheet
Set chart = .ChartObjects("Chart 4")
' Copy the chart as a picture
chart.chart.ChartArea.Copy
' Paste the chart into the PowerPoint slide and get the reference to the pasted shape
Set pptShape = pptSlide.Shapes.PasteSpecial(DataType:=2)(1) ' 2 represents ppPasteEnhancedMetafile
Application.CutCopyMode = False
' Set the size and position of the pasted shape
With pptShape
.LockAspectRatio = msoFalse
.Height = 11.64 * 28.35 ' Set the desired Height in cm
.Width = 16.23 * 28.35 ' Set the desired width in cm
.Left = 16.93 * 28.35 ' Set the desired width in cm
.Top = 3.53 * 28.35 ' Set the desired width in cm
End With
'------------------------------------- External end -----------------------------------------------
'slide 15
'------------------------------------- Internal start ----------------------------------------------
'chart5 - Internal AR Total
' Select the chart from the Excel worksheet
Set chart = .ChartObjects("Chart 5")
' Copy the chart as a picture
chart.chart.ChartArea.Copy
' Select the slide
Set pptSlide = pptPres.Slides(15)
' Paste the chart into the PowerPoint slide and get the reference to the pasted shape
Set pptShape = pptSlide.Shapes.PasteSpecial(DataType:=2)(1) ' 2 represents ppPasteEnhancedMetafile
Application.CutCopyMode = False
' Set the size and position of the pasted shape
With pptShape
.LockAspectRatio = msoFalse
.Height = 11.64 * 28.35 ' Set the desired Height in cm
.Width = 16.23 * 28.35 ' Set the desired width in cm
.Left = 0.71 * 28.35 ' Set the desired width in cm
.Top = 3.53 * 28.35 ' Set the desired width in cm
End With
'chart6 - Internal AR Due
' Select the chart from the Excel worksheet
Set chart = .ChartObjects("Chart 6")
' Copy the chart as a picture
chart.chart.ChartArea.Copy
' Paste the chart into the PowerPoint slide and get the reference to the pasted shape
Set pptShape = pptSlide.Shapes.PasteSpecial(DataType:=2)(1) ' 2 represents ppPasteEnhancedMetafile
Application.CutCopyMode = False
' Set the size and position of the pasted shape
With pptShape
.LockAspectRatio = msoFalse
.Height = 11.64 * 28.35 ' Set the desired Height in cm
.Width = 16.23 * 28.35 ' Set the desired width in cm
.Left = 16.93 * 28.35 ' Set the desired width in cm
.Top = 3.53 * 28.35 ' Set the desired width in cm
End With
'------------------------------------- Internal end ----------------------------------------------
'slide 16
'--------------- External and Internal (Top 10 Due> 360 Days) start ------------------------------
'chart7 - External AR due > 360 Days
' Select the chart from the Excel worksheet
Set chart = .ChartObjects("Chart 7")
' Copy the chart as a picture
chart.chart.ChartArea.Copy
' Select the slide
Set pptSlide = pptPres.Slides(16)
' Paste the chart into the PowerPoint slide and get the reference to the pasted shape
Set pptShape = pptSlide.Shapes.PasteSpecial(DataType:=2)(1) ' 2 represents ppPasteEnhancedMetafile
Application.CutCopyMode = False
' Set the size and position of the pasted shape
With pptShape
.LockAspectRatio = msoFalse
.Height = 11.64 * 28.35 ' Set the desired Height in cm
.Width = 16.23 * 28.35 ' Set the desired width in cm
.Left = 0.71 * 28.35 ' Set the desired width in cm
.Top = 3.53 * 28.35 ' Set the desired width in cm
End With
'chart8 - Internal AR due > 360 Days
' Select the chart from the Excel worksheet
Set chart = .ChartObjects("Chart 8")
' Copy the chart as a picture
chart.chart.ChartArea.Copy
' Paste the chart into the PowerPoint slide and get the reference to the pasted shape
Set pptShape = pptSlide.Shapes.PasteSpecial(DataType:=2)(1) ' 2 represents ppPasteEnhancedMetafile
Application.CutCopyMode = False
' Set the size and position of the pasted shape
With pptShape
.LockAspectRatio = msoFalse
.Height = 11.64 * 28.35 ' Set the desired Height in cm
.Width = 16.23 * 28.35 ' Set the desired width in cm
.Left = 16.93 * 28.35 ' Set the desired width in cm
.Top = 3.53 * 28.35 ' Set the desired width in cm
End With
'--------------- External and Internal (Top 10 Due> 360 Days) end ------------------------------
End With
'Application.StatusBar = "closing file"
DoEvents
wb.Close 'SaveChanges:=False
DoEvents
Set pptSlide = Nothing
Set pptShape = Nothing
Set ws = Nothing
End Sub