Excel VBA to powerpoint

Question

I am basically looking for a way to trim below code. It works just fine.

This code takes a range from each tab of an excel spreadsheet and pastes it into a powerpoint file, then assigns a title to each slide after pasting.

I feel the code is way too long and can be trimmed. I use excel 2016.

Everywhere the comment 'repeat appears in the code is basically repeating the copy and paste from excel tab to powerpoint then assigning a title to that slide. I took some bits and pieces and trimmed them, but I feel there is room for more.

 Sub CommercialtoPowerPoint()
'declare variables
Dim otherWB As Workbook
Dim ws As Worksheet
Dim PP As PowerPoint.Application
Dim PPPres As PowerPoint.Presentation
Dim PPslide As PowerPoint.Slide
Dim Sh As PowerPoint.Shape
Dim Bh As PowerPoint.Shape
Dim GSF As Workbook
Dim SlideTitle As String
'opening powerpoint and creating a new presentation
Set GSF = Workbooks("Support Function P&L Details FY23-Update File")
Set PP = New PowerPoint.Application
Set PPPres = PP.Presentations.Add
PP.Visible = True
'adding new slide to PP presentation and using for further use
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
'setting slide size from 16:9 to 4:3
PPslide.Application.ActivePresentation.PageSetup.SlideSize = 1 'ppSlideSizeOnScreen = 1
'code to copy range from excel sheet
Sheets("Commercial-H1").Select
Sheets("Commercial-H1").Range("B3:L220").Copy
'pasting picture and adjusting positing
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
'Adding title to slide and align center
SlideTitle = "H1 P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-LAM").Select
Sheets("Commercial-LAM").Range("B3:L220").Copy
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "LAM P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-EMEA").Select
Sheets("Commercial-EMEA").Range("B3:L220").Copy
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "EMEA P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-APAC").Select
Sheets("Commercial-APAC").Range("B3:L220").Copy
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "APAC P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-HS Admin").Select
Sheets("Commercial-HS Admin").Range("B3:L220").Copy
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "HS Admin P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-Corp").Select
Sheets("Commercial-Corp").Range("B3:L220").Copy
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "Corp P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'repeat
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
Sheets("Commercial-all").Select
Sheets("Commercial-all").Range("B3:L220").Copy
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = "Full P&L"
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False
'Adding slide for Headcount and moving to last slide
Dim slideCount As Long
slideCount = PPPres.Slides.Count
Set PPslide = PPPres.Slides.Add(slideCount + 1, ppLayoutTitleOnly)
PPslide.Select
PPslide.Shapes(1).TextFrame.TextRange.Text = "Headcount"
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = Arial
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
'setting powerpoint title
Set PPslide = PPPres.Slides.Add(1, ppLayoutTitle)
PPslide.Select
PPslide.Shapes(1).TextFrame.TextRange.Text = "Monthly P&L Report"
PPslide.Shapes(2).TextFrame.TextRange.Text = "Commercial"
'back to excel sheet and select cell A1 in every sheet
GSF.Activate
Application.CutCopyMode = False
For Each ws In GSF.Sheets
ws.Activate
ws.[a1].Select
Next ws
GSF.Worksheets(1).Activate
'powerpoint memory cleanup
PP.Activate
Set PPslide = Nothing
Set PPPres = Nothing
Set PP = Nothing
Set Sh = Nothing
Set Bh = Nothing
Set GSF = Nothing
End Sub

Answer 1

Replace repeated operations with local helper methods

With the addition of helper methods, duplicated code can be greatly reduced. Here, copying a Range from a worksheet to update a PowerPoint Slide is repeated 7 times:

'code to copy range from excel sheet
Sheets("Commercial-H1").Select
Sheets("Commercial-H1").Range("B3:L220").Copy
'pasting picture and adjusting positing
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With

Create a helper subroutine:

Private Sub CopyToSlide(ByVal wkSheetName As String, ByVal PPslide As PowerPoint.Slide)
 Sheets(wkSheetName).Select
 
 Sheets(wkSheetName).Range("B3:L220").Copy
 
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
End Sub

After making the simplest/easiest improvement, sometimes other opportunities to remove duplication become easier to see. That is the case here. Once CopyToSlide to used, it is easier to see a larger block of duplicated code.

With CopyToSlide the duplicated code lines now look like...

Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
PPslide.Select
CopyToSlide <sheet name>, PPslide
PP.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
Application.CutCopyMode = False
SlideTitle = <title>
PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
Set Sh = PPslide.Shapes.Title
Sh.Height = 20
Sh.TextEffect.FontBold = msoCTrue
Sh.TextEffect.FontName = "Arial"
PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
Application.CutCopyMode = False

The only difference between the blocks of similar code is the worksheet name and SlideTitle. So, adding an additional subroutine that takes a PowerPoint.Presentation object, a worksheet name, and the slide's title can be used to eliminate the duplication:

Private Sub AddSlideForWorksheet(ByVal PPPres As PowerPoint.Presentation, ByVal wkSheetName As String, ByVal SlideTitle As String)
 
 Dim PPslide As PowerPoint.Slide
 Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
 
 PPslide.Application.ActivePresentation.PageSetup.SlideSize = 1 'ppSlideSizeOnScreen = 1
 PPslide.Select
 
 CopyToSlide wkSheetName, PPslide
 
 PPPres.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
 
 Application.CutCopyMode = False
 
 PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
 
 Dim Sh As PowerPoint.Shape
 Set Sh = PPslide.Shapes.Title
 Sh.Height = 20
 Sh.TextEffect.FontBold = msoCTrue
 Sh.TextEffect.FontName = "Arial"
 PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered
 
 Application.CutCopyMode = False
End Sub

With the addition of AddSlideForWorksheet, a lot of duplicated code has been removed. That said, there is still a block of code that is duplicated less, but is still duplicated twice:

 Dim Sh As PowerPoint.Shape
 Set Sh = PPslide.Shapes.Title
 Sh.Height = 20
 Sh.TextEffect.FontBold = msoCTrue
 Sh.TextEffect.FontName = "Arial"
 PPslide.Shapes.Title.TextEffect.Alignment = msoTextEffectAlignmentCentered

This led to one last helper method FormatTitle:

Private Sub FormatTitle(ByVal PPslide As PowerPoint.Slide)
 With PPslide.Shapes.Title
 .Height = 20
 .TextEffect.FontBold = msoCTrue
 .TextEffect.FontName = "Arial"
 .TextEffect.Alignment = msoTextEffectAlignmentCentered
 End With
End Sub

With these 3 helper methods, the length of CommercialtoPowerPoint is greatly reduced and the module's code now looks like:

Option Explicit
Sub CommercialtoPowerPoint()
 'opening powerpoint and creating a new presentation
 
 Dim GSF As Workbook
 Set GSF = Workbooks("Support Function P&L Details FY23-Update File")
 
 Dim PP As PowerPoint.Application
 Set PP = New PowerPoint.Application
 Dim PPPres As PowerPoint.Presentation
 Set PPPres = PP.Presentations.Add
 PP.Visible = True
 
 AddSlideForWorksheet PPPres, "Commercial-H1", "H1 P&L"
 AddSlideForWorksheet PPPres, "Commercial-LAM", "LAM P&L"
 AddSlideForWorksheet PPPres, "Commercial-EMEA", "EMEA P&L"
 AddSlideForWorksheet PPPres, "Commercial-APAC", "APAC P&L"
 AddSlideForWorksheet PPPres, "Commercial-HS Admin", "HS Admin P&L"
 AddSlideForWorksheet PPPres, "Commercial-Corp", "Corp P&L"
 AddSlideForWorksheet PPPres, "Commercial-all", "Full P&L"
 
 'Adding slide for Headcount and moving to last slide
 Dim slideCount As Long
 slideCount = PPPres.Slides.Count
 Dim PPslide As PowerPoint.Slide
 Set PPslide = PPPres.Slides.Add(slideCount + 1, ppLayoutTitleOnly)
 PPslide.Select
 PPslide.Shapes(1).TextFrame.TextRange.Text = "Headcount"
 
 FormatTitle PPslide
 
 'setting powerpoint title
 Set PPslide = PPPres.Slides.Add(1, ppLayoutTitle)
 PPslide.Select
 PPslide.Shapes(1).TextFrame.TextRange.Text = "Monthly P&L Report"
 PPslide.Shapes(2).TextFrame.TextRange.Text = "Commercial"
 
 'back to excel sheet and select cell A1 in every sheet
 GSF.Activate
 Application.CutCopyMode = False
 
 Dim ws As Worksheet
 For Each ws In GSF.Sheets
 ws.Activate
 ws.[a1].Select
 Next ws
 
 GSF.Worksheets(1).Activate
 
 'powerpoint memory cleanup
 PP.Activate
 'Removed statements setting local variables to 'Nothing'
 'When local variables go out of scope they are destroyed
End Sub
Private Sub AddSlideForWorksheet(ByVal PPPres As PowerPoint.Presentation, ByVal wkSheetName As String, ByVal SlideTitle As String)
 
 Dim PPslide As PowerPoint.Slide
 Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
 
 PPslide.Application.ActivePresentation.PageSetup.SlideSize = 1 'ppSlideSizeOnScreen = 1
 PPslide.Select
 
 CopyToSlide wkSheetName, PPslide
 
 PPPres.Application.ActiveWindow.Selection.ShapeRange.Align msoAlignCenters, True
 
 Application.CutCopyMode = False
 
 PPslide.Shapes.Title.TextFrame.TextRange.Text = SlideTitle
 
 FormatTitle PPslide
 
 Application.CutCopyMode = False
End Sub
Private Sub CopyToSlide(ByVal wkSheetName As String, ByVal PPslide As PowerPoint.Slide)
 ActiveWorkbook.Sheets(wkSheetName).Select
 
 ActiveWorkbook.Sheets(wkSheetName).Range("B3:L220").Copy
 
 'pasting picture and adjusting positing
 With PPslide.Shapes.PasteSpecial(DataType:=ppPasteEnhancedMetafile)
 .Width = 666.72
 .Height = 390.24
 End With
End Sub
Private Sub FormatTitle(ByVal PPslide As PowerPoint.Slide)
 With PPslide.Shapes.Title
 .Height = 20
 .TextEffect.FontBold = msoCTrue
 .TextEffect.FontName = "Arial"
 .TextEffect.Alignment = msoTextEffectAlignmentCentered
 End With
End Sub

Declaring Local Variables

The VBA Language imposes a format/order for module variable and procedure declarations. That is, the module-scope variables must be declared before the first procedure declaration. So, it is common to find a list of variable declarations at the top of a VBA module.

The module-scope variable declaration rule often finds its way into the format of local-scope declarations. However, local-scope variables (those declared within a procedure) are not required to be declared at the top of a procedure - they can be declared anywhere within the procedure. It is considered a Best-Practice to declared local variables as close as possible to their first use. The reason behind the best practice is that it makes the code much easier to read/understand when the declaration and its first use.

Option Explicit

(Best Practice) Always declare Option Explicit at the top of your modules. This allows the compiler to flag the use of variables that have not been explicitly declared. This reveals hard to find bugs (i.e., due to typos). Make it automatic: in the VBIDE, check the 'Tools -> Options... -> (Editor tab) 'Require Variable Declaration' option.

• Sorab: does not work :(...i was trying to use one vba code with button to do this. Not sure how to combine private sub with regular sub to do this.
• BZngr: @Sorab Learning to use small and focused functions to reduce repeated blocks of code is a very important skill to learn and apply in VBA or any programming language. Otherwise, there are few options when "looking for a way to trim the code...". I've added the 3 helper functions to the code example of the refactored CommercialtoPowerPoint. Hopefully from the updated example you can see how to arrange and call a function from another function.