Const ModelText As String = "机构名称"

Const ModelName As String = "测试文件.pptx"

Sub NextSeven_CodeFrame()

    '应用程序设置

    Application.ScreenUpdating = False

    Application.DisplayAlerts = False

    Application.Calculation = xlCalculationManual

    '错误处理

    On Error GoTo ErrHandler

    '计时器

    Dim StartTime, UsedTime As Variant

    StartTime = VBA.Timer

    '变量声明

    Dim Wb As Workbook

    Dim Sht As Worksheet

    Dim Rng As Range

    Dim Arr As Variant

    Dim EndRow As Long

    Dim pApp As Object

    Dim Pre As Object

    'Dim pApp As PowerPoint.Application

    'Dim pre As PowerPoint.Presentation

    Dim FindStr As String

    Dim ReplaceStr As String

    Dim FilePath As String

    Dim FolderPath As String

    Dim tmp As String

    Dim FileName As String

    FileName = Left(ModelName, InStrRev(ModelName, ".") - 1)

    '实例化对象

    Set Wb = Application.ThisWorkbook

    Set Sht = Wb.Worksheets(1)

    FolderPath = Wb.Path & "\"

    'Set pApp = New PowerPoint.Application

    Set pApp = CreateObject("PowerPoint.Application")

    Debug.Print FolderPath & ModelName

    Set Pre = pApp.Presentations.Open(FolderPath & ModelName)

    With Sht

        EndRow = .Cells(.Cells.Rows.Count, 1).End(xlUp).Row

        Set Rng = .Range("A1:Z" & EndRow)

        Arr = Rng.Value

        For i = LBound(Arr) To UBound(Arr)

            If i = 1 Then

                FindStr = ModelText

                ReplaceStr = Arr(i, 1)

                FilePath = FolderPath & FileName & "_予" & Arr(i, 1) & ".pdf"

                ReplaceAndPublish Pre, FilePath, FindStr, ReplaceStr

            Else

                FindStr = Arr(i - 1, 1)

                ReplaceStr = Arr(i, 1)

                FilePath = FolderPath & FileName & "_予" & Arr(i, 1) & ".pdf"

                ReplaceAndPublish Pre, FilePath, FindStr, ReplaceStr

            End If

        Next i

    End With

    '运行耗时

    UsedTime = VBA.Timer - StartTime

    'MsgBox "本次运行耗时：" & Format(UsedTime, "0.0000000秒")

ErrorExit:        '错误处理结束，开始环境清理

    Pre.Close

    Set Pre = Nothing

    pApp.Quit

    Set pApp = Nothing

    Set Wb = Nothing

    Set Sht = Nothing

    Set Rng = Nothing

    Application.ScreenUpdating = True

    Application.DisplayAlerts = True

    Application.Calculation = xlCalculationAutomatic

    Exit Sub

ErrHandler:

    If Err.Number <> 0 Then

        MsgBox Err.Description & "！", vbCritical, "错误提示！"

        'Debug.Print Err.Description

        Err.Clear

        Resume ErrorExit

    End If

End Sub

Private Sub ReplaceAndPublish(ByVal Pre As Object, ByVal FilePath As String, ByVal FindText As String, ByVal ReplaceText As String)

    Dim sld As PowerPoint.Slide

    Dim shp As PowerPoint.Shape

    Dim Txt As String

    For Each sld In Pre.Slides

        For Each shp In sld.Shapes

            If shp.HasTextFrame = msoTrue Then

                If shp.TextFrame.HasText Then

                    Txt = shp.TextFrame.TextRange.Text

                    If InStr(1, Txt, FindText) > 0 Then

                        shp.TextFrame.TextRange.Text = Replace(Txt, FindText, ReplaceText)

                        Exit For

                    End If

                End If

            End If

        Next

    Next

    Pre.SaveAs FilePath, ppSaveAsPDF

End Sub