Trim a excel VBA that copies data from various tabs into Powerpoint-CodePudding

I am basically looking for a way to trim below code. Code works just fine. This code takes a range from each tab of excel and paste it into powerpoint and then assigns a title to each slide after pasting, but I feel the code is way too long and can be trimmed. I use excel 2016. Also worth mentioning that everywhere it says repeat, it is basically repeating the copy and paste from excel tab to powerpoint then assigning a title to that slide.

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

I took some bits and pieces and trimmed them, but I feel there is room for more.

CodePudding user response：

This new version of the code uses two arrays, one for the sheet names and another one for the slide titles. It also uses a loop to iterate through the sheets and titles. This way, you don't need to repeat the same code multiple times.

Also removed the unused variables and made the font name a string.

Sub CommercialtoPowerPoint()

    'declare variables
    Dim PP As PowerPoint.Application
    Dim PPPres As PowerPoint.Presentation
    Dim PPslide As PowerPoint.Slide
    Dim Sh As PowerPoint.Shape
    Dim slideTitle As String

    'opening powerpoint and creating a new presentation
    Set PP = New PowerPoint.Application
    Set PPPres = PP.Presentations.Add
    PP.Visible = True

    'setting slide size from 16:9 to 4:3
    PPPres.PageSetup.SlideSize = 1

    'Array of sheet names
    Dim sheetNames() As String
    sheetNames = Array("Commercial-H1", "Commercial-LAM", "Commercial-EMEA")

    'Array of slide titles
    Dim slideTitles() As String
    slideTitles = Array("H1 P&L", "LAM P&L", "EMEA P&L")

    'loop through the sheets
    For i = 0 To UBound(sheetNames)
        'adding new slide to PP presentation and using for further use
        Set PPslide = PPPres.Slides.Add(1, ppLayoutTitleOnly)
        PPslide.Select

        'code to copy range from excel sheet
        Sheets(sheetNames(i)).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

        'Adding title to slide and align center
        slideTitle = slideTitles(i)
        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
    Next i
    Application.CutCopyMode = False
End Sub

CodePudding user response：

I figured it out. @German code is good, but needs 2 changes below:

Declare (this was missing)

Dim i As Integer

and change 2 lines below

Dim sheetNames() As String

This needs to be

Dim sheetNames() As Variant

and

Dim slideTitles() As String

needs to be

Dim slideTitles() As Variant

Minor correction and this solved the problem!