How to Copy and Print each Named Range on a Power Point Presentation Slides with Excel VBA Macro

Macro to Copy and Print each Named Range on a Power Point Presentation Slides
The following Macro is designed to Print the Named Ranges whose names like PPT_01,PPT_02,PPT_03........PPPT_XX., of This Workbook on Power Point Presentation Slides of specified PowerPoint Template Deck which is Pre-designed.
Please edit this Macro before using as per your Requirement.
----------------------------------------------------------------------
Sub Gen_PPT_for_MyNamedRanges()
    Dim New_PPT As PowerPoint.Presentation
    Dim PPT_Slide As PowerPoint.Slide
    Dim Exl_WB As Object
    Dim PPT_File As String
    Dim Slides_Count As Integer
    Dim PPT_No As Integer
    Dim Rng As Object
    Dim Rng_Name As String
    Dim CopyRange As Range
    
    K = 0
' << An Existing PPT Presentation Deck with Defined Slides >>
    PPT_File = ThisWorkbook.Sheets("C_PANEL").Range("B2").Value
    
' << Saving Path of Output PPT Presentation and its Name >>
    Save_Path = ThisWorkbook.Sheets("C_PANEL").Range("B3").Value
    OutPut_Name = ThisWorkbook.Sheets("C_PANEL").Range("B1").Value
       
    Set New_PowerPoint = Nothing
    On Error Resume Next
    Set New_PowerPoint = GetObject(, "PowerPoint.Application")
    On Error GoTo 0
    
 '<< Check whether a PPT Application is Open, if open Close and open a New App >>
        If New_PowerPoint Is Nothing Then
            Set New_PowerPoint = New PowerPoint.Application
            New_PowerPoint.Visible = msoCTrue
            New_PowerPoint.DisplayAlerts = False
        Else
            New_PowerPoint.Quit
            Set New_PowerPoint = New PowerPoint.Application
            New_PowerPoint.Visible = msoCTrue
            New_PowerPoint.DisplayAlerts = False
           On Error GoTo 0
        End If
        
    Set Exl_WB = ThisWorkbook
       
    Set New_PPT = New_PowerPoint.Presentations.Open(Filename:=PPT_File)    
' << Counting the No.of Slides in the Active PPT File >>
    Slides_Count = New_PowerPoint.ActivePresentation.Slides.Count
    
' << Looping through each Named Range in Workbook >>
For Each Rng In Exl_WB.Names
        Rng_Name = Rng.Name     
'<<Checking the Named Range name should be like 'PPT_01',PPT_02... and it should not contain '!'  >>.
    If InStr(1, Rng_Name, "PPT") > 0 And InStr(1, Rng_Name, "!") = 0 Then
     PPT_No = Int(Right(Rng_Name, 2)) 

'<< Adjust back the Slide Number on Which we Print Named Range when it More than Slides_Count >>'
    '<< This one type of logic used in different scenario >>
        If PPT_No > Slides_Count Then
            K = K + 1
            PPT_No = 15+ K ' Change as per your requirement
        End If
     '<< --------------------- >>'
       
     New_PowerPoint.ActiveWindow.View.GotoSlide (PPT_No)
     Set PPT_Slide = New_PowerPoint.ActivePresentation.Slides(PPT_No)
   
 ' << Storing the Range Reference in a Variable >>
          Rng_Ref = Exl_WB.Names(Rng_Name).Value
         
'<< Checking whether there is any Ref# error in the Range Refereed.>>                   
          If InStr(1, Rng_Ref, "REF") = 0 Then                    
'<< Storing Named Range in a variable >>
          Set CopyRange = Exl_WB.Names(Rng_Name).RefersToRange
                             
'<<Activating the Active Named Range Sheet and Copying that Range >>
          Rng_Sht_Name = Exl_WB.Names(Rng_Name).RefersToRange.Parent.Name
                             Exl_WB.Sheets(Rng_Sht_Name).Activate
                             Exl_WB.Activate
                             CopyRange.Select
                             CopyRange.Copy

                        Count = 0

                        On Error GoTo ErrorHandler
'<< Copying the Named Range as a Pitcure and Pasting default on the Slide >>
             CopyRange.CopyPicture xlScreen, xlPicture
             New_PowerPoint.Activate

'<< Pasting on the Active Slide >>
             PPT_Slide.Select
             PPT_Slide.Shapes.PasteSpecial(ppPasteDefault,Link:=RangeLink).Select

'<< Pasting with Source Formatting >>
             PPT_Slide.Select
             PPT_Slide.Application.CommandBars.ExecuteMso ("PasteSourceFormatting")

'<< Method-I :Re-size the Picture as it fit to Active Slide >>
                     With PPT_Slide.Shapes(1)
                                 .Select
                                 .LockAspectRatio = False
                                 .Top = 5
                                 .Width = 710
                                 .Left = 5
                                 .Height = 500
                                 .PictureFormat.TransparentBackground = True
                      End With

'<< Method-II :Re-size the Picture as it fit to Active Slide >>
      NewPowerPoint.ActiveWindow.Selection.ShapeRange.LockAspectRatio = msoFalse
              NewPowerPoint.ActiveWindow.Selection.ShapeRange.Width = 710
              NewPowerPoint.ActiveWindow.Selection.ShapeRange.Height = 500
              NewPowerPoint.ActiveWindow.Selection.ShapeRange.Left = 5
              NewPowerPoint.ActiveWindow.Selection.ShapeRange.Top = 20

             End If

       End If
       
 Next Rng
   
'<<Deleting desired/unwanted Slide >>
      Set PPT_Slide = New_PowerPoint.ActivePresentation.Slides(12)
            PPT_Slide.Delete

'<<Moving/Changing the Slide Position >>
New_PowerPoint.ActivePresentation.Slides(7).MoveTo ToPos:=23

'<< Saving the Presentation with the Specified Output Name in given Path >>
        New_PPT.SaveAs (Save_Path & "\" & OutPut_Name & ".pptx")
        New_PPT.Close

        Application.DisplayAlerts = True
        Application.Calculation = xlCalculationAutomatic

    On Error Resume Next
    New_PowerPoint.Quit
        Exit Sub

ErrorHandler:
        Count = Count + 1
    
    Resume
    If Count = 200 Then
MsgBox "Error: Cannot copy the Range from Excel, Please contact Tech Team on this Issue"
        Exit Sub
    End If

End Sub

Note :
Dear Users , You may not understand this whole Macro , but a few lines in this Macro may be useful for your own requirement.

--------------------------------------------------------------------------------------------------------

Thanks, TAMATAM ; Business Intelligence & Analytics Professional

--------------------------------------------------------------------------------------------------------