Sub delenie_na_fio()

    Dim imf_save As String
    Dim pole_otd As Integer
    Dim put_fl As String
               
put_fl = "D:\Work\Заявления\"
                n = 0
                
On Error Resume Next
  ActiveDocument.MailMerge.DataSource.ActiveRecord = wdFirstRecord
  Do
    With ActiveDocument.MailMerge
        .Destination = wdSendToNewDocument
        .SuppressBlankLines = True
        With .DataSource
            .FirstRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
            .LastRecord = ActiveDocument.MailMerge.DataSource.ActiveRecord
        
        pole_fam = ActiveDocument.MailMerge.DataSource.DataFields(2).Value
        pole_otd = ActiveDocument.MailMerge.DataSource.DataFields(3).Value
        pole = pole_otd & " " & pole_fam

        Application.StatusBar = pole
            imf_save = put_fl & pole & " заявление.doc"

        End With
        .Execute Pause:=False
    
    End With
    
    ActiveDocument.SaveAs FileName:= _
        imf_save, FileFormat:= _
        wdFormatDocument, LockComments:=False, Password:="", AddToRecentFiles:= _
        True, WritePassword:="", ReadOnlyRecommended:=False, EmbedTrueTypeFonts:= _
        False, SaveNativePictureFormat:=False, SaveFormsData:=False, _
        SaveAsAOCELetter:=False
    ActiveDocument.Close
    ActiveDocument.MailMerge.DataSource.ActiveRecord = wdNextRecord

                n = n + 1
       Loop Until n = ActiveDocument.MailMerge.DataSource.RecordCount

End Sub