Sub diplomy()
    Dim objPP As Object, workPP  As Object
    Dim sFileName As String
    Dim i As Long, lr As Long
    'порверка активности POWERPNT.exe
    On Error Resume Next
        Set objPP = GetObject(, "PowerPoint.Application")
        If Err <> 0 Then Set objPP = CreateObject("PowerPoint.Application")
        Err.Clear
    On Error GoTo 0
    
    sFileName = ThisWorkbook.Path & "\Diplom.pptx"
    Set workPP = objPP.Presentations.Open(sFileName, , , msoFalse)
    lr = Cells(Rows.Count, 1).End(xlUp).Row
    For i = 2 To lr
        With workPP.slides(1)
            .Shapes("FIO").TextFrame.TextRange.Text = Cells(i, 1)
            .Shapes("Kurs").TextFrame.TextRange.Text = Cells(i, 2)
            .Shapes("Data").TextFrame.TextRange.Text = Cells(i, 5)
        End With
        workPP.SaveCopyAs ThisWorkbook.Path & "\Diplom-Курс " & Cells(i, 2) & "-" & Cells(i, 1) & ".pptx"
    Next i
    workPP.Close
    MsgBox "Done!"
End Sub