Friday, November 21, 2014

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
--------------------------------------------------------------------------------------------------------

No comments:

Post a Comment

Hi User, Thank You for visiting My Blog. Please post your genuine Feedback or comments only related to this Blog Posts. Please do not post any Spam comments or Advertising kind of comments which will be Ignored.

Featured Post from this Blog

How to compare Current Snapshot Data with Previous Snapshot in Power BI

How to Dynamically compare two Snapshots Data in Power BI Scenario: Suppose, we have a sample Sales data, which is stored with Monthly Snaps...

Popular Posts from this Blog