Transfer text from one power point to another to change the pattern

Question

I am very new to 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 power points out of 100 slides, so it would be easier for me with this solution.

Thank you in advance for your help.

ACCURACY: I do not want to copy and paste a text range, but copy text within a range to fit it in a new range. Below is the code that I already have, but it doesn’t "Insert it into 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 a short way to transfer one text range from PowerPoint A to another text range located in Powerpoint B?

I think there is no short way to do this, but try something first!

Long answer:

Note. This decision is not based on your desired behavior (since it is unclear to me, and there are many more cases of “what if”), but on a similar problem, so I think it is legal. In any case, this is a good foundation to start with.

Entrance:

I don’t know how your presentations look, so I made a link (presentation A) and broken link (presentation B). Let's take a look at them:

• Presentation A (5 slides: 1x “slide slide” with 2 triangle shapes, 3x “Title and content headings”, 1x “Section title slider”:

• Presentation B (5 slides: 1x “title slide” of missing triangular shapes, 3x “Title and content” slides with empty / no shapes (placeholders), 1x “Empty” slide (incorrect layout)):

• Both presentations are in one folder:

  

Desired behavior:

Some kind of synchronization, if we skip the figure, then create it and apply the desired text on it, if it is, place only the desired text (based on the presentation of A shape). There are some what-ifs in logic:

• "What should I do if the number of slides in each presentation is not equal? ​​In what order do the slides compare? (In our case, the number is equal, so in the code we discard this part and compare a pair of slides in a pair).
• What if comparison slides have a different layout? (In our case, the difference is in the blank layout, so we can easily handle this, but what should we do as a whole?)
• ... and many other cases not covered by this decision

Logics:

The logic is simple and simple. The entry point to our program is in presentation A, as this is our link file. From this point, we get a link to presentation B (when you open it) and start the iteration in two cycles (through each pair of slides and through the reference figures). If we find a “broken” (or not one, don’t check) the form with a link, we put text and some parameters in it or create a new form (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 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 a desired behaviourfor this case? 'We can change layout for target presentation but it adds complexity 'But let 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 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 is difficult to find any difference in the screenshot (it can even be photoshop, anyway, there are several differences for this purpose), but for the full answer here:

Output:

As you can see, the difficult task is to achieve something similar to your desire, but the complexity of the solution depends on the source data and “what if” cases, so there is no shortcut for solving this problem as a whole (in my humble opinion). Hooray!

Answer 2

There are several different interpretations in your question, below is my attempt to answer what I believe, the question. There are several steps to solving this problem.

1. Make sure we keep the VBA we write

First, we must accept the main presentation, that is, one that will store the values ​​that will be copied to all the others. This needs to be saved as a presentation with macro support (pptm) ​​so that we can save our VBA. This is done using File > Save-As and when choosing a save location, select PowerPoint Macro-Enabled Presentation in the Save as type field.

2. Enable Windows Scripting Environment

In the pptm 'master' presentation presented to us, open the VBA IDE (Alt + F11). From the menu bar, select Tools > References... and mark Microsoft Scripting Runtime from the list provided. Click OK to close the dialog box with your tick. This is necessary for some error handling in the code, it checks if the presentation exists before trying to open it.

3. Paste the provided code

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

In the main editing area, paste below (I added comments 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 "Error: -" and vbNewLine and vbNewLine and Err.Number and ":" and Err.Description, vbOKOnly + vbExclamation, "Error", Err.Clear End Sub

4. Configure code

You will need to add the paths and location of the changes, and then it should work.