This code is wonderful. I have a query, what if the text (in ppt) is written in more than one taxt box, then it does not work,
Can you do a favour for editing the code for multiple text boxes inside a slide?
Regards
HansV wrote: ↑06 Feb 2017, 10:23See the modified workbook and presentation in the zip file.
The workbook now contains a macro
This macro will prompt you to select the presentation with the template slide; at the end it will prompt you to save the completed presentation under another name.Code: Select all
Sub Merge2PPT() Dim pptApp As PowerPoint.Application ' Object Dim pptPrs As PowerPoint.Presentation ' Object Dim pptSld As PowerPoint.Slide ' Object Dim pptShp As PowerPoint.Shape Dim strFile As String Dim r As Long Dim m As Long strFile = Application.GetOpenFilename("PowerPoint Presentations (*.pptx),*.pptx", , "Select PowerPoint file") If strFile = "False" Then Beep Exit Sub End If On Error Resume Next Set pptApp = GetObject(Class:="PowerPoint.Application") If pptApp Is Nothing Then Set pptApp = CreateObject(Class:="PowerPoint.Application") If pptApp Is Nothing Then Beep Exit Sub End If End If On Error GoTo 0 ' ErrHandler pptApp.Visible = msoCTrue Set pptPrs = pptApp.Presentations.Open(strFile, , , msoFalse) m = Range("A" & Rows.Count).End(xlUp).Row For r = m To 2 Step -1 pptPrs.Slides(1).Duplicate Set pptSld = pptPrs.Slides(2) Set pptShp = pptSld.Shapes(1) With pptShp.TextFrame.TextRange .Replace "<1>", Range("D" & r).Value .Replace "<2>", Range("A" & r).Value .Replace "<3>", Range("C" & r).Value .Replace "<4>", Range("B" & r).Value End With Next r pptPrs.Slides(1).Delete pptPrs.NewWindow With pptApp.FileDialog(msoFileDialogSaveAs) .InitialFileName = pptPrs.Path & "\New.pptx" If .Show Then .Execute End With ExitHandler: Exit Sub ErrHandler: MsgBox Err.Description, vbExclamation Resume ExitHandler End Sub
I added placeholders <1>, <2>, ... for the name etc. in the slide; the code replaces these with values from the worksheet.