Option Explicit

Sub SaveIndividualWordFiles()
Dim i As Long
Dim docMail As Document
Dim docLetters As Document
Dim savePath As String, sFName As String

    Set docMail = ActiveDocument
    savePath = docMail.path & "\"

    With docMail.MailMerge
        For i = 1 To .DataSource.RecordCount
            .Destination = wdSendToNewDocument
            .SuppressBlankLines = True
            With .DataSource
                .FirstRecord = i
                .LastRecord = i
                .ActiveRecord = i
                '' This will be the file name
                '' the test data source had unique surnames
                '' in a field (column) called FileName
                sFName = .DataFields("Title").value
            End With
            .Execute Pause:=False
            Set docLetters = ActiveDocument

            ' Save generated document and close it after saving
             docLetters.SaveAs FileName:=savePath & sFName & ".docx"
            docLetters.Close False
            DoEvents
        Next
    End With
Set docMail = Nothing
Set docLetters = Nothing
End Sub