how can i use mail merge in ppt

mayaz
NewLounger
Posts: 1
Joined: 25 Dec 2021, 17:05

Re: how can i use mail merge in ppt

Post by mayaz »

Dear,
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:23
See the modified workbook and presentation in the zip file.
The workbook now contains a macro

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
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.
I added placeholders <1>, <2>, ... for the name etc. in the slide; the code replaces these with values from the worksheet.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

Welcome to Eileen's Lounge!

Could you attach a PowerPoint presentation with an example of the slide you want to use?
Best wishes,
Hans

mayaz
NewLounger
Posts: 1
Joined: 25 Dec 2021, 17:05

Re: how can i use mail merge in ppt

Post by mayaz »

Thanks HansV,

I have attached the sample ppt file. Basically, I have to use two text boxes inside a single slide, in which there are either single/multiple values to be replaced using excel.
You do not have the required permissions to view the files attached to this post.
Last edited by mayaz on 27 Dec 2021, 15:38, edited 1 time in total.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

Thank you. Here is a modified macro:

Code: Select all

Sub Merge2PPT()
    Dim pptApp As Object
    Dim pptPrs As Object
    Dim pptSld As Object
    Dim pptShp As Object
    Dim strFile As String
    Dim r As Long
    Dim m As Long
    ' Prompt for source presentstion
    strFile = Application.GetOpenFilename("PowerPoint Presentations (*.pptx),*.pptx", , "Select PowerPoint file")
    If strFile = "False" Then
        Beep
        Exit Sub
    End If
    ' Get or stsrt PowerPoint
    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 ErrHandler
    pptApp.Visible = msoCTrue
    ' Open presentation
    Set pptPrs = pptApp.Presentations.Open(strFile, , , msoFalse)
    ' Last used row
    m = Range("A" & Rows.Count).End(xlUp).Row
    ' Loop through the rows
    For r = m To 2 Step -1
        ' Copy first slide
        pptPrs.Slides(1).Duplicate
        ' Refer to new slide
        Set pptSld = pptPrs.Slides(2)
        ' Three placeholders on first shape
        Set pptShp = pptSld.Shapes(1)
        With pptShp.TextFrame.TextRange
            .Replace "<1>", Range("A" & r).Value
            .Replace "<2>", Range("B" & r).Value
            .Replace "<3>", Range("C" & r).Value
        End With
        ' Two placeholders on second shape
        Set pptShp = pptSld.Shapes(2)
        With pptShp.TextFrame.TextRange
            .Replace "<4>", Range("D" & r).Value
            .Replace "<5>", Range("E" & r).Value
        End With
    Next r
    ' Delete the first slide
    pptPrs.Slides(1).Delete
    ' Show presentation in a window
    pptPrs.NewWindow
    ' Prompt to save the presentation with a new name
    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 have attached a sample workbook with some dummy data to merge, and with the macro.

PPT_Demo.xlsm
You do not have the required permissions to view the files attached to this post.
Best wishes,
Hans

Miran
NewLounger
Posts: 3
Joined: 17 Jan 2022, 06:49

Re: how can i use mail merge in ppt

Post by Miran »

Can you help modifying the code for this template and data sheet? I have tried the last code but it didn't work....
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

Welcome to Eileen's Lounge!

All tables on the slide were named "Table 9", making it impossible to distinguish them. I have given them unique names.
Moreover, you didn't save the presentation at the end.
See the attached versions.

11th MAIN List for Merge.xlsm
New Microsoft PowerPoint Presentation.pptx
You do not have the required permissions to view the files attached to this post.
Best wishes,
Hans

Miran
NewLounger
Posts: 3
Joined: 17 Jan 2022, 06:49

Re: how can i use mail merge in ppt

Post by Miran »

Hi Hans,

It worked.... Thanks a ton man....

Miran
NewLounger
Posts: 3
Joined: 17 Jan 2022, 06:49

Re: how can i use mail merge in ppt

Post by Miran »

Hi Hans,

reviving this thread again.
can we pull photos (JPG/PNG) from a folder according to the staff ID in the Photo segment of the PPT?

I have attached the file and template again
You do not have the required permissions to view the files attached to this post.
Last edited by Miran on 11 Oct 2022, 05:28, edited 1 time in total.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

Here you go. The new parts are between ***

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 pptTbl As PowerPoint.Table
    Dim strFile As String
    Dim r As Long
    Dim m As Long
    Dim i As Long
    Dim j As Long
    Dim arr
    Dim k As Long
    ' *** New variables ***
    Dim ID As String
    Dim strFolder As String
    ' ***
    strFile = Application.GetOpenFilename("PowerPoint Presentations(*.pptx),*.pptx", , "Select PowerPoint file")
    If strFile = "False" Then
        Beep
        Exit Sub
    End If
    ' *** Prompt for picture folder ***
    With Application.FileDialog(4)
        .Title = "Select the folder with the staff photos"
        If .Show Then
            strFolder = .SelectedItems(1)
            If Right(strFolder, 1) <> "\" Then
                strFolder = strFolder & "\"
            End If
        Else
            Beep
            Exit Sub
        End If
    End With
    ' ***
    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)
        ' *** Insert picture if available ***
        ID = Cells(r, 1).Value
        strFile = Dir(strFolder & ID & ".jpg")
        If strFile <> "" Then
            Set pptShp = pptSld.Shapes("Rectangle 7")
            pptShp.Fill.UserPicture strFolder & strFile
        End If
        ' ***
        Set pptShp = pptSld.Shapes("TextBox 3")
        With pptShp.TextFrame.TextRange
            .Replace "<2>", Range("B" & r).Value
        End With
        Set pptTbl = pptSld.Shapes("Table 1").Table
        pptTbl.Cell(1, 2).Shape.TextFrame.TextRange.Text = Cells(r, 3).Value
        Set pptTbl = pptSld.Shapes("Table 2").Table
        pptTbl.Cell(1, 2).Shape.TextFrame.TextRange.Text = Cells(r, 39).Value
        pptTbl.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(r, 1).Value
        pptTbl.Cell(3, 2).Shape.TextFrame.TextRange.Text = Year(Cells(r, 4).Value)
        pptTbl.Cell(4, 2).Shape.TextFrame.TextRange.Text = Cells(r, 5).Value
        pptTbl.Cell(5, 2).Shape.TextFrame.TextRange.Text = Format(Cells(r, 6).Value, "Short Date")
        arr = Array(20, 18, 17, 19, 24, 22, 21, 23, 28, 26, 25, 27)
        k = 0
        Set pptTbl = pptSld.Shapes("Table 3").Table
        For i = 2 To 4
            For j = 1 To 4
                pptTbl.Cell(i, j).Shape.TextFrame.TextRange.Text = Cells(r, arr(k)).Value
                k = k + 1
            Next j
        Next i
        arr = Array(9, 7, 8, 10, 11, 14, 12, 13, 15, 16, 38, 35, 36, 37)
        k = 0
        Set pptTbl = pptSld.Shapes("Table 4").Table
        For i = 2 To 4
            For j = 1 To 4
                If i < 4 And j = 2 Then
                    pptTbl.Cell(i, j).Shape.TextFrame.TextRange.Text = Cells(r, arr(k)).Value & _
                        ", " & Cells(r, arr(k)).Value
                    k = k + 2
                Else
                    pptTbl.Cell(i, j).Shape.TextFrame.TextRange.Text = Cells(r, arr(k)).Value
                    k = k + 1
                End If
            Next j
        Next i
        Set pptTbl = pptSld.Shapes("Table 8").Table
        pptTbl.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(r, 29).Value
        pptTbl.Cell(3, 2).Shape.TextFrame.TextRange.Text = Cells(r, 30).Value
        pptTbl.Cell(4, 2).Shape.TextFrame.TextRange.Text = Cells(r, 31).Value
        Set pptTbl = pptSld.Shapes("Table 10").Table
        pptTbl.Cell(2, 2).Shape.TextFrame.TextRange.Text = Cells(r, 32).Value
        pptTbl.Cell(3, 2).Shape.TextFrame.TextRange.Text = Cells(r, 33).Value
        pptTbl.Cell(4, 2).Shape.TextFrame.TextRange.Text = Cells(r, 34).Value
    Next r
    pptPrs.Slides(1).Delete
    pptPrs.NewWindow
    With pptApp.FileDialog(msoFileDialogSaveAs)
        .InitialFileName = pptPrs.Path & "\New.pptx"
        If .Show Then
            pptPrs.SaveAs Filename:=.SelectedItems(1)
        End If
    End With
ExitHandler:
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub
Best wishes,
Hans

Miran
NewLounger
Posts: 3
Joined: 17 Jan 2022, 06:49

Re: how can i use mail merge in ppt

Post by Miran »

Hi Hans,
Thanks a lot, man. Really appreciate the effort.

vojtababka@gmail.com
NewLounger
Posts: 8
Joined: 03 Aug 2023, 17:01

Re: how can i use mail merge in ppt

Post by vojtababka@gmail.com »

Hello,
i would kindly ask for your help. I really tried my best but could not figure it out.

I just need to connect excel data for <1>,<2>,<3>.......<x> - in ppt each value should be in separate text box, sometimes there is one text box on slide, sometimes there are multiple textboxes on slide. But there is always only one value in one text box.
I need separate pptx file for each student. I just cant manage to fill other values than <1>.

Would someone be so kind and help me ? It is driving me crazy :) Thank you all a lot for any effort made

Vojtech Babka
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

Welcome to Eileen's Lounge!

In your sample presentation, there are three slides with one text box each. Should the text boxes be filled from columns A, B and C?

Could there be other configurations? If so, please explain in more detail what should happen.
Best wishes,
Hans

vojtababka@gmail.com
NewLounger
Posts: 8
Joined: 03 Aug 2023, 17:01

Re: how can i use mail merge in ppt

Post by vojtababka@gmail.com »

Hello,

exactly - <1> for column A, <2> B.....

I added one more slide, where can appear two textboxes on slide.
But is it important for macro how many text objects will be on what slide ? can it be somehow like - ok if you find text object with <1> on any slide, fill it with data from column A and so ?
Sorry maybe i look on it to easily.....
In final there should be around 10 slides with 1 to 4 textboxes to fill. There will be only 1 value in one text box. There will be also other textboxes with simple text (not tobe filled).
Thank you for your reaction
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

Modified code:

Code: Select all

Sub Merge2PPT()
    Dim pptApp As Object
    Dim pptPrs As Object
    Dim pptSld As Object
    Dim pptShp As Object
    Dim strFile As String
    Dim r As Long
    Dim c As Long
    Dim m As Long
    Dim n As Long
    Dim f As Boolean
    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
        f = True
    End If
   On Error GoTo 0 ' ErrHandler
    m = Cells(Rows.Count, 1).End(xlUp).Row
    n = Cells(1, Columns.Count).End(xlToLeft).Column
    For r = 2 To m
        Set pptPrs = pptApp.Presentations.Open(strFile, , , msoFalse)
        For Each pptSld In pptPrs.Slides
            For Each pptShp In pptSld.Shapes
                If pptShp.Type = 17 Then ' msoTextBox
                    For c = 1 To n
                        pptShp.TextFrame.TextRange.Replace "<" & c & ">", Cells(r, c).Value
                    Next c
                End If
            Next pptShp
        Next pptSld
        pptPrs.SaveAs Filename:=pptPrs.Path & "\" & Range("A" & r).Value & ".pptx", _
            FileFormat:=24
        pptPrs.Close
    Next r
ExitHandler:
    On Error Resume Next
    If f Then
        pptApp.Quit
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub
See the attached workbook.

macro_test.xlsm
You do not have the required permissions to view the files attached to this post.
Best wishes,
Hans

snb
4StarLounger
Posts: 547
Joined: 14 Nov 2012, 16:06

Re: how can i use mail merge in ppt

Post by snb »

This might do as well.
I removed the text after 'Hello ' in the first slide.
I saved your ppt-file in 'G:\OF\test2.pptx'

Code: Select all

Sub M_snb()
  sn = Sheet1.Cells(1).CurrentRegion
  
  If UBound(sn) > 1 Then
     With GetObject("G:\OF\test2.pptx")
       For j = 2 To UBound(sn) - 1
         .Slides.Range(Array(1, 2, 3, 4)).Duplicate
       Next
       For j = 2 To UBound(sn)
         .Slides(4 * (j - 2) + 1).Shapes(1).TextFrame.TextRange = .Slides(4 * (j - 2) + 1).Shapes(1).TextFrame.TextRange & sn(j, 1)
       Next
     End With
  End If
End Sub
NB. Comment out 'Option Explicit'

vojtababka@gmail.com
NewLounger
Posts: 8
Joined: 03 Aug 2023, 17:01

Re: how can i use mail merge in ppt

Post by vojtababka@gmail.com »

Thank you so much for your help. Sorry for late response i was sick.
@HansV - it working really great.

But - two more questions please
1) sometimes while exporting it gives me errorr in part below - it generates only first row from excel
Set pptPrs = pptApp.Presentations.Open(strFile, , , msoFalse)
But then it is working fine

2) Is there possibility to save Powerpoint as .mp4 format ? or at least ppsx ? I tried to edit it by myself but with no luck.

Thank you so much for your useful help

BR
Vojtech Babka

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

1) Could you attach an example file where the error occurs?
2) To export as MP4, change

Code: Select all

        pptPrs.SaveAs Filename:=pptPrs.Path & "\" & Range("A" & r).Value & ".pptx", _
            FileFormat:=24
to

Code: Select all

        pptPrs.SaveAs Filename:=pptPrs.Path & "\" & Range("A" & r).Value & ".mp4", _
            FileFormat:=39
(I haven't tested it myself)
Best wishes,
Hans

vojtababka@gmail.com
NewLounger
Posts: 8
Joined: 03 Aug 2023, 17:01

Re: how can i use mail merge in ppt

Post by vojtababka@gmail.com »

Hello thank you for quick reply.
The MP4 file saving returning an error - please see attachmnent.

Thank you if any idea to fix comes to you :)
You do not have the required permissions to view the files attached to this post.

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

I will test when I get back home.
Best wishes,
Hans

User avatar
HansV
Administrator
Posts: 78236
Joined: 16 Jan 2010, 00:14
Status: Microsoft MVP
Location: Wageningen, The Netherlands

Re: how can i use mail merge in ppt

Post by HansV »

This works for me:

Code: Select all

Sub Merge2PPT()
    Dim pptApp As Object
    Dim pptPrs As Object
    Dim pptSld As Object
    Dim pptShp As Object
    Dim strFile As String
    Dim r As Long
    Dim c As Long
    Dim m As Long
    Dim n As Long
    Dim f As Boolean
    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
        f = True
    End If
   On Error GoTo 0 ' ErrHandler
    m = Cells(Rows.Count, 1).End(xlUp).Row
    n = Cells(1, Columns.Count).End(xlToLeft).Column
    For r = 2 To m
        Set pptPrs = pptApp.Presentations.Open(strFile, , , msoFalse)
        For Each pptSld In pptPrs.Slides
            For Each pptShp In pptSld.Shapes
                If pptShp.Type = 17 Then ' msoTextBox
                    For c = 1 To n
                        pptShp.TextFrame.TextRange.Replace "<" & c & ">", Cells(r, c).Value
                    Next c
                End If
            Next pptShp
        Next pptSld
        ' Save as .ppsx
        pptPrs.SaveAs Filename:=pptPrs.Path & "\" & Range("A" & r).Value & ".ppsx", _
            FileFormat:=28
        ' Save as .mp4
        pptPrs.SaveAs Filename:=pptPrs.Path & "\" & Range("A" & r).Value & ".mp4", _
            FileFormat:=39
        'pptPrs.Close
    Next r
ExitHandler:
    On Error Resume Next
    If f Then
        pptApp.Quit
    End If
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub
Result:

S2436.png
You do not have the required permissions to view the files attached to this post.
Best wishes,
Hans