how can i use mail merge in ppt

[prince]

Hello Sir, I want to know how can i use mail merge in PPT. I have 100 excel records that i want to attach with presentation slides. But i am not able to do this.
Thank you.

[HansV]

PowerPoint itself does not have a mail merge feature, so it requires VBA code.

What is your purpose?
1) Print the slide once for each student
2) Create a separate PowerPoint file for each student
3) Create a single PowerPoint file with a slide for each student

[prince]

Single page of slide use for differnt students. I want to make the admit card of all students with same pattern .

[HansV]

Yes, but do you want one .pptx file with many slides, or many .pptx files with one slide each?

[prince]

1 pptx file with maný slides.

[HansV]

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.

[prince]

Sir, When i execute excel macro then its showing an error message .
Thanks & regard
Prince

[Rudi]

Hi Price,

I see Hans has used late binding to PowerPoint in his code, and also left comments for Object in his declarations. Maybe his intention was to change it afterwards.
It will work if you change the PowerPoint.* declarations to Object declarations at the beginning of your macro, like this...

Code: Select all

Sub Merge2PPT()
    Dim pptApp As Object
    Dim pptPrs As Object
    Dim pptSld As Object
    Dim pptShp As Object
    ....

[HansV]

Thanks, Rudi. I did intend to change the declarations, but forgot about it at the last moment.

[prince]

Thank You So much Mr. Rudi & HansV. Its working perfectly.
With regards,
Prince

[prince]

if i want to add few more column in ppt then where i should change is macro code. I have added 3 more columns in Excel sheet marked by yellow color. How can i add these column in PPT.
Regards,
Prince

[HansV]

That should be obvious: just add the following lines.

Code: Select all

            .Replace "<5>", Range("E" & r).Value
            .Replace "<6>", Range("F" & r).Value
            .Replace "<7>", Range("G" & r).Value

[prince]

Thanks sir, its working.

[Anandbabu.m]

PowerPoint itself does not have a mail merge feature, so it requires VBA code.

What is your purpose?
1) Print the slide once for each student
2) Create a separate PowerPoint file for each student
3) Create a single PowerPoint file with a slide for each student

Hi,

Need your help in getting separate powerpoint file for each student. Can you update the macro accordingly.
It will be of great help.

[HansV]

Welcome to Eileen's Lounge!

Here is a modified macro, based on the layout of the presentation used in this thread:

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 f As Boolean
    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
        f = True
    End If
    On Error GoTo 0 ' ErrHandler
    m = Range("A" & Rows.Count).End(xlUp).Row
    For r = 2 To m
        Set pptPrs = pptApp.Presentations.Open(strFile, , , msoFalse)
        Set pptSld = pptPrs.Slides(1)
        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
            .Replace "<4>", Range("D" & r).Value
        End With
        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

[pritishk]

Hi Hans, thanks a lot for the above codes! These are really helpful..
I was actually trying to emulate the code and try and fit for my context in this ppt.. However, this doesn't seem to work.. Would you be kind enough to help here..

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("A" & r).Value
            .Replace "<2>", Range("B" & r).Value
            .Replace "<3>", Range("C" & r).Value
            .Replace "<4>", Range("D" & r).Value
            .Replace "<5>", Range("E" & r).Value
            .Replace "<6>", Range("F" & r).Value
            .Replace "<7>", Range("G" & r).Value
            .Replace "<8>", Range("H" & r).Value
            .Replace "<9>", Range("I" & r).Value
            .Replace "<10>", Range("J" & r).Value
            .Replace "<11>", Range("K" & r).Value
            .Replace "<12>", Range("L" & r).Value
            .Replace "<13>", Range("M" & r).Value
            .Replace "<14>", Range("N" & r).Value
            .Replace "<15>", Range("O" & r).Value
            .Replace "<16>", Range("P" & r).Value
            .Replace "<17>", Range("Q" & r).Value
            .Replace "<18>", Range("R" & r).Value
            .Replace "<19>", Range("S" & r).Value
            .Replace "<20>", Range("T" & r).Value
            .Replace "<21>", Range("U" & r).Value
            .Replace "<22>", Range("V" & r).Value
            .Replace "<23>", Range("W" & r).Value
            .Replace "<24>", Range("X" & r).Value
            .Replace "<25>", Range("Y" & r).Value
            .Replace "<26>", Range("Z" & r).Value
            .Replace "<27>", Range("AA" & r).Value
            .Replace "<28>", Range("AB" & r).Value
            .Replace "<29>", Range("AC" & r).Value
            .Replace "<30>", Range("AD" & r).Value
            .Replace "<31>", Range("AE" & r).Value
            .Replace "<32>", Range("AF" & r).Value
            .Replace "<33>", Range("AG" & r).Value
            .Replace "<34>", Range("AH" & r).Value
            .Replace "<35>", Range("AI" & r).Value
            .Replace "<36>", Range("AJ" & r).Value
            .Replace "<37>", Range("AK" & r).Value
            .Replace "<38>", Range("AL" & r).Value
            .Replace "<39>", Range("AM" & r).Value
            .Replace "<40>", Range("AN" & 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

[HansV]

Welcome to Eileen's Lounge!

The code needs to be modified extensively, since your placeholder texts such as <1> etc. are not in a single shape, but in one shape and three tables.
I'll see if I can come up with something.

[HansV]

Here is the modified code:

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
    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
    arr = Array(3, 4, 6, 8, 7, 9, 10, 11, 12, 13)
    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("Shape 90")
        With pptShp.TextFrame.TextRange
            .Replace "<2>", Range("B" & r).Value
            .Replace "<5>", Range("E" & r).Value
        End With
        k = 0
        Set pptTbl = pptSld.Shapes("Table 6").Table
        For i = 1 To 5
            For j = 2 To 4 Step 2
                pptTbl.Cell(i, j).Shape.TextFrame.TextRange.Text = Cells(r, arr(k)).Value
                k = k + 1
            Next j
        Next i
        Set pptTbl = pptSld.Shapes("Table 2").Table
        For i = 2 To 5
            For j = 1 To 6
                pptTbl.Cell(i, j).Shape.TextFrame.TextRange.Text = Cells(r, 6 * i + j + 1).Value
            Next j
        Next i
        Set pptTbl = pptSld.Shapes("Table 1").Table
        For i = 2 To 6
            For j = 1 To 6
                pptTbl.Cell(i, j).Shape.TextFrame.TextRange.Text = Cells(r, 6 * i + j + 25).Value
            Next j
        Next i
    Next r
    pptPrs.Slides(1).Delete
    pptPrs.NewWindow
    With pptApp.FileDialog(msoFileDialogSaveAs)
        .InitialFileName = pptPrs.Path & "\New.pptx"
        .Show
    End With
ExitHandler:
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

And the modified presentation (you don't need the placeholder text in the tables):

Format.pptx

[pritishk]

Thanks a lot!
This really helps! :)

Will trouble you as I decode the code and make some minor tweaks, hope that's ok :)

[HansV]

Sure,feel free to come back!