how can i use mail merge in ppt

[vojtababka@gmail.com]

Hmm that is weird - i have tried on multiple PCs and office version and it is not working for me tho . Can you please check if MP4 file you have generated has any size - or if you open it plays video ? I managed to get mp4 file, but with 0 size.

Thank you.

[HansV]

Yes - it did play.

I have Office 2021.

[vojtababka@gmail.com]

Finally i managed to get official OFfice 2021 and it is wokring fine (it didnt for o365).
But i would like to ask one more favor.
Can you please add function in macro, that will save .mp4 to a new created folder based on name e.g. /<Column1>_<Column2>/<Column1>_<Column2>.mp4 ?

That would be really useful for me. I tried it to do by myself, but - well - it is no go for me :D
Thank you very much in advance

[HansV]

1) Should the code create the folder?
2) Are you on Mac or on Windows?

[vojtababka@gmail.com]

Hello,
1) yes it should create folder - it is enough to create subfolders in the folder where ppt or xls template is located
2) using windows

Thanks VB

[HansV]

Try this version:

Code: Select all

Sub Merge2PPT()
    Dim pptApp As Object
    Dim pptPrs As Object
    Dim pptSld As Object
    Dim pptShp As Object
    Dim strPath As String
    Dim strFile As String
    Dim r As Long
    Dim c As Long
    Dim m As Long
    Dim n As Long
    Dim f As Boolean
    Dim ps As String
    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
    ps = Application.PathSeparator
    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 & ps & Range("A" & r).Value & ".ppsx", _
            FileFormat:=28
        ' Save as .mp4
        strPath = pptPrs.Path & ps & Range("A" & r).Value & "_" & Range("B" & r).Value
        If Dir(strPath, vbDirectory) = "" Then
            MkDir strPath
        End If
        pptPrs.SaveAs Filename:=strPath & ps & _
            Range("A" & r).Value & "_" & Range("B" & 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

[snb]

Did you try ?

Code: Select all

ActivePresentation.createvideo "G:\OF\example.mp4"

[vojtababka@gmail.com]

WOW WONDERFUL IT IS WORKING PERFECTLY.

Last thing - sorry.

I want to show values with thousand separator "space" - but for that i have tio use values as text in excel original file.

Do you have any tip how to combine left & right function to be able to add space after each 3 characters from right to left ?

E,.g i have number stored as text 1222333 and need to change it to 1 222 333. it works for me for values, but not the tex.

Thank you

[HansV]

New version:

Code: Select all

Sub Merge2PPT()
    Dim pptApp As Object
    Dim pptPrs As Object
    Dim pptSld As Object
    Dim pptShp As Object
    Dim strPath As String
    Dim strFile As String
    Dim r As Long
    Dim c As Long
    Dim m As Long
    Dim n As Long
    Dim v As Variant
    Dim f As Boolean
    Dim ps As String
    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
    ps = Application.PathSeparator
    m = Cells(Rows.Count, 1).End(xlUp).Row
    m = 4
    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
                        v = Cells(r, c).Value
                        If IsNumeric(v) Then
                            Select Case v
                                Case Is > 999999999
                                    v = Format(v, "0 000 000 000")
                                Case Is > 999999
                                    v = Format(v, "0 000 000")
                                Case Is > 999
                                Case Else
                            End Select
                        End If
                        pptShp.TextFrame.TextRange.Replace "<" & c & ">", v
                    Next c
                End If
            Next pptShp
        Next pptSld
        ' Save as .ppsx
        pptPrs.SaveAs Filename:=pptPrs.Path & ps & Range("A" & r).Value & ".ppsx", _
            FileFormat:=28
        ' Save as .mp4
        strPath = pptPrs.Path & ps & Range("A" & r).Value & "_" & Range("B" & r).Value
        If Dir(strPath, vbDirectory) = "" Then
            MkDir strPath
        End If
        pptPrs.SaveAs Filename:=strPath & ps & _
            Range("A" & r).Value & "_" & Range("B" & 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