Transferring text range from 1 power point to another to change template

Question

I am very new with Powerpoint VBA and would like to know if there is a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B in a specific sequence.

Page a1 = b1

Page a2 = b2

Page a3 = b3

The template is changing and I need to adapt 5 powerpoints of 100 slides so I tought it would be easier with this solution.

Thank you in advance for your help.

PRECISION : I don't want to copy and paste the text range but to copy the text inside the range to put it inside the new range. Please find below the code I already have but It doesnt' Paste it inside my new range.

Sub copier_texte()  'je veux copier le contenu de la forme, et non pas la forme en entier

Dim nb_slide As Integer
nb_slide = ActivePresentation.Slides.Count

With ActivePresentation
.Slides(1).Shapes(2).TextFrame.TextRange.Copy 'je sélectionne uniquement le contenu de la forme
For i = 2 To .Slides.Count
        .Slides(i).Select
        ActiveWindow.View.Paste
Next i
End With

End Sub 

Answer 1

Short Answer:

Is there're a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?

I think that there's no short way to do it, but let's try something first!

Long Answer:

Note: This solution based not on your desired behaviour (since it's unclear for me and there're many and more "what if" cases), but on similar problem, so I think that it's legit. Anyway it's a good fundament to start of.

Input:

I dont know how exactly your presentations looks like, so I made a reference one ( Presentation A ) and a "broken" one ( Presentation B ). Let's take a look on them:

• Presentation A (5 slides: 1x"Title slide" with 2 triangle shapes, 3x"Title and Content" slides, 1x"Section Header" slide):

• Presentation B (5 slides: 1x"Title slide" missing triangle shapes, 3x"Title and Content" slides with empty/without shapes(placeholders), 1x"Blank" slide (wrong layout)):

• Both presentations are in the same folder:

  

Desired behaviour:

Some sort of synchronisation, if we miss a shape - then create one and put desired text to it, if there's one - put desired text only (based on Presentations A's shape). There're some "what if" cases in logic:

• "What if" the number of slides in each presentation isn't equal? In which order compare slides then? (In our case the number is equal, so in code we drop that part and compare slides pair by pair).
• "What if" the compared slides have a different layout? (In our case difference in blank layout, so we can easily handle it, but what we should do in general?)
• ...and many other cases not considered in this solution

Logic:

Logic is plain and simple. The entry point to our routine is in the Presentation A , since it's an our reference file. From that point we acquire a reference to Presentation B (when opening it), and start iteration in two loops (thru each pair of slides and thru reference shapes). If we found a "broken" (or not so, there's no check for that) shape by a reference one - we put text and some options in it or create a new one shape (or placeholder) otherwise.

Option Explicit

Sub Synch()
    'define presentations
    Dim ReferencePresentation As Presentation
    Dim TargetPresentation As Presentation

    'define reference objects
    Dim ReferenceSlide As Slide
    Dim ReferenceSlides As Slides
    Dim ReferenceShape As Shape

    'define target objects
    Dim TargetSlide As Slide
    Dim TargetSlides As Slides
    Dim TargetShape As Shape

    'define other variables
    Dim i As Long


    'Setting-up presentations and slide collections
    Set ReferencePresentation = ActivePresentation
    With ReferencePresentation
        Set TargetPresentation = Presentations.Open(FileName:=.Path & "/Presentation B.pptm", _
                WithWindow:=msoFalse)
        Set ReferenceSlides = .Slides
    End With

    Set TargetSlides = TargetPresentation.Slides

    'Check slide count
    If ReferenceSlides.Count <> TargetSlides.Count Then
        'What's a desired behaviour for this case?
        'We can add slides to target presentation but it adds complexity
        Debug.Print "ERROR!" & vbTab & "Reference And Target slides counts are not equal!"
    Else
        '"mainloop" for slides
        For i = 1 To ReferenceSlides.Count
            Set ReferenceSlide = ReferenceSlides(i)
            Set TargetSlide = TargetSlides(i)

            'Check slide layout
            If ReferenceSlide.Layout <> TargetSlide.Layout Then
                'What's a desired behaviourfor this case?
                'We can change layout for target presentation but it adds complexity
                'But let's try to change a layout too, since we have an easy case in our example!
                Debug.Print "WARNING!" & vbTab & "Reference And Target slides layouts are not same!"
                TargetSlide.Layout = ReferenceSlide.Layout
            End If

            '"innerloop" for shapes (for placeholders actually)
            With ReferenceSlide
                For Each ReferenceShape In .Shapes
                    Set TargetShape = AcquireShape(ReferenceShape, TargetSlide, True)

                    If TargetShape Is Nothing Then
                        Debug.Print "WARNING!" & vbTab & "There's no shape like " & ReferenceShape.Name
                    ElseIf TargetShape.HasTextFrame Then
                        With TargetShape.TextFrame.TextRange
                            'paste text
                            .Text = ReferenceShape.TextFrame.TextRange.Text
                            'and options
                            .Font.Size = ReferenceShape.TextFrame.TextRange.Font.Size
                            .Font.Name = ReferenceShape.TextFrame.TextRange.Font.Name
                            .Font.Color.RGB = ReferenceShape.TextFrame.TextRange.Font.Color.RGB
                            '...
                        End With
                    End If
                Next
            End With
        Next
    End If

    'Save and close target presentation
    Call TargetPresentation.Save
    Call TargetPresentation.Close
End Sub


Function AcquireShape(ByRef ReferenceShape As Shape, ByRef TargetSlide As Slide, _
        Optional ByVal CreateIfNotExists As Boolean) As Shape
    Dim TargetShape As Shape

    With ReferenceShape
        'seek for existed shape
        For Each TargetShape In TargetSlide.Shapes
            If TargetShape.Width = .Width And TargetShape.Height = .Height And _
                    TargetShape.Top = .Top And TargetShape.Left = .Left And _
                    TargetShape.AutoShapeType = .AutoShapeType Then
                Set AcquireShape = TargetShape
                Exit Function
            End If
        Next

        'create new
        If CreateIfNotExists Then
            If .Type = msoPlaceholder Then
                Set AcquireShape = TargetSlide.Shapes.AddPlaceholder(.PlaceholderFormat.Type, .Left, .Top, .Width, .Height)
            Else
                Set AcquireShape = TargetSlide.Shapes.AddShape(.AutoShapeType, .Left, .Top, .Width, .Height)
            End If
        End If
    End With
End Function

Output:

I know that it's hard to find any difference by a screenshot (it's can be even photoshoped, anyway there're a few difference for that purpose), but for a full answer, here it is:

Conclusion:

As you see, it isn't a hard task to achieve something similar to your desire, but complexity of solution depends on inputs and on "what if" cases, hence there's no short way to overcome this task in general (in my humble opinion). Cheers!

Answer 2

Your question has a number of different interpretations, below is my attempt to answer what I believe the question is. There are a number of stage to this solution.

1. Ensure we save the VBA we write

Firstly, we have to assume a master presentation, that is one that will hold the values to be copied into all others. This will need to be saved as a macro enabled presentation (pptm) to allow us to save our VBA. This is done via File > Save-As and while selecting the save location choose PowerPoint Macro-Enabled Presentation in the Save as type box.

2. Enable Windows scripting runtime

Within the pptm 'master' presentation that we now have, open the VBA IDE (Alt+F11). In the menu bar select Tools > References... and tick Microsoft Scripting Runtime from the list that is presented. Click OK to close the references dialog box with your tick remembered. This is needed for some error handling in the code, it checks to see if the presentation exists before trying to open it.

3. Insert the provided code

Right-click on VBAProject in the upper right area (the Project explorer) and select Insert > Module .

In the main editing area paste the below (I have added commenting to describe what is happening): -

Option Explicit

Public Sub Update()
Dim AryPresentations(4) As String
Dim LngPID              As Long
Dim FSO                 As New FileSystemObject
Dim PP_Src              As Presentation
Dim PP_Dest             As Presentation
Dim Sld_Src             As Slide
Dim Sld_Dest            As Slide
Dim Shp_Src             As Shape
Dim Shp_Dest            As Shape
Dim LngFilesMissing     As Long
Dim BlnWasOpen          As Boolean

'If there is an error, this will handle it and stop the process
On Error GoTo ErrorHandle

'Increase the size of AryPresentations and and the paths as shown in the example below
AryPresentations(0) = "C:\Users\garye\Desktop\PP2.pptx"
AryPresentations(1) = "C:\Users\garye\Desktop\PP3.pptx"
AryPresentations(2) = "C:\Users\garye\Desktop\PP4.pptx"
AryPresentations(3) = "C:\Users\garye\Desktop\PP5.pptx"
AryPresentations(4) = "C:\Users\garye\Desktop\PP6.pptx"

'PP_Src is this, our 'master' presentation
Set PP_Src = ActivePresentation

'This loops through each item in AryPresentations
For LngPID = 0 To UBound(AryPresentations, 1)

    'We rememeber if you had it open already as if you did, then we won't close it when we are done
    BlnWasOpen = False

    'Check all currently open presentations to see if one if the presentation we are due to update
    For Each PP_Dest In PowerPoint.Presentations
        If Trim(UCase(PP_Dest.FullName)) = Trim(UCase(AryPresentations(LngPID))) Then Exit For
    Next

    'If it was not already open, check it exists and if it does, then open in
    If PP_Dest Is Nothing Then
        If FSO.FileExists(AryPresentations(LngPID)) Then
            Set PP_Dest = PowerPoint.Presentations.Open(AryPresentations(LngPID))
        End If
    Else
        BlnWasOpen = True
    End If

    If PP_Dest Is Nothing Then
        Debug.Print "File note found"
        LngFilesMissing = LngFilesMissing + 1
    Else
        'The below connects to the slide (Sld_Src) you want to pick up from, the shape (Shp_Src) you want to pick up from and then
        'places it in the slide (Sld_Dest) you want it to go to into the shape (Shp_Dest) you want it to go in to
        Set Sld_Src = PP_Src.Slides(1)
            Set Sld_Dest = PP_Dest.Slides(1)
                Set Shp_Src = Sld_Src.Shapes(1)
                    Set Shp_Dest = Sld_Dest.Shapes(1)
                        Shp_Dest.TextFrame.TextRange.Text = Shp_Src.TextFrame.TextRange.Text
                    Set Shp_Dest = Nothing
                Set Shp_Src = Nothing
            Set Sld_Dest = Nothing
        Set Sld_Src = Nothing
        'Repeat the above for each piece of text to copy

        'Finally save the changes
        PP_Dest.Save

        'Close the presentation if it was not already open
        If Not BlnWasOpen Then PP_Dest.Close

    End If
Next

MsgBox "Process complete. Number of missing files: " & LngFilesMissing, vbOKOnly + vbInformation, "Complete"

Exit Sub

ErrorHandle: MsgBox "There was an error: - " & vbNewLine & vbNewLine & Err.Number & ": " & Err.Description, vbOKOnly + vbExclamation, "Error" Err.Clear End Sub

4. Customise code

You'll want to add the paths and location of the changes in and then it should run.