Excel to ppt macro error

[prince]

Hello Sir/Madam, I'm trying to connect the excel VBA to ppt but its not connecting. I have more than 2000 data in excel that I want to connect with PPT to generate admit card. But VBA code have error. Please help to solve the error.
Copy enclosed
Thanks and regards,
Prince

[HansV]

You are referring to the wrong shape. The shape that contains <1> etc. is the first GroupItem in the group box Group 13.
And the data begin in row 3, not in row 2.

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
    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
    Set pptPrs = pptApp.Presentations.Open(strFile, , , msoFalse)
    m = Range("A" & Rows.Count).End(xlUp).Row
    ' **** Stop at row 3 ****
    For r = m To 3 Step -1
        Set pptSld = pptPrs.Slides(1).Duplicate
        ' **** Process the first GroupItem in Group 13 ****
        Set pptShp = pptSld.Shapes("Group 13").GroupItems(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
        End With
    Next r
    pptPrs.Slides(1).Delete
    pptApp.Visible = msoCTrue
    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

[prince]

It's working perfactly. Thank you so much. Really grateful to you.

[prince]

Sir, I want to know if i use Title without group then which line I need to be changed. I want to understand that single line only. Please guide.
PPt copy enclosed here with previous excel file.
With regards,
Prince

[HansV]

Change the

Code: Select all

        Set pptShp = pptSld.Shapes(2)

to

Code: Select all

        Set pptShp = pptSld.Shapes("Title 4")

[prince]

Thank you.