If the field chosen for the filename contains the same data for multiple records then of course the documents will be overwritten by subsequent records. The sample data you provided has different data in each record in the Title field and so produces six documents.
If you want to account for duplicate names, you need a lot more code. You will also need to test for illegal filename characters (there were none in your Title field example) and it is probably wider to use a subfolder to save the merged documents. The following does that also.
Code:
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 & "\Merged Documents\"
CreateFolders savePath
With docMail.MailMerge
For i = 1 To .DataSource.RecordCount
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
sFName = .DataFields("Title").value
sFName = CleanFilename(sFName)
sFName = FileNameUnique(savePath, sFName, "docx")
End With
.Execute Pause:=False
Set docLetters = ActiveDocument
docLetters.SaveAs FileName:=savePath & sFName & ".docx"
docLetters.Close False
DoEvents
Next
End With
Set docMail = Nothing
Set docLetters = Nothing
End Sub
Private Function CleanFilename(strFileName As String) As String
Dim arrInvalid() As String
Dim lng_Index As Long
'Define illegal characters (by ASCII CharNum)
arrInvalid = Split("9|10|11|13|34|42|47|58|60|62|63|92|124", "|")
'Remove any illegal filename characters
CleanFilename = strFileName
For lng_Index = 0 To UBound(arrInvalid)
CleanFilename = Replace(CleanFilename, Chr(arrInvalid(lng_Index)), Chr(95))
Next lng_Index
lbl_Exit:
Exit Function
End Function
Private Function FileNameUnique(strPath As String, _
strFileName As String, _
strExtension As String) As String
'Graham Mayor - http://www.gmayor.com - Last updated - 22 Jun 2018
'strPath is the path in which the file is to be saved
'strFilename is the filename to check
'strExtension is the extension of the filename to check
Dim lng_F As Long
Dim lng_Name As Long
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
Do Until Right(strPath, 1) = "\"
strPath = strPath & "\"
Loop
If InStr(1, strFileName, "\") > 0 Then
strFileName = Mid(strFileName, InStrRev(strFileName, "\") + 1)
End If
strExtension = Replace(strExtension, Chr(46), "")
lng_F = 1
If InStr(1, strFileName, strExtension) > 0 Then
lng_Name = Len(strFileName) - (Len(strExtension) + 1)
Else
lng_Name = Len(strFileName)
End If
strFileName = Left(strFileName, lng_Name)
'If the filename exists, add or increment a number to the filename
'and keep checking until a unique name is found
Do While FSO.FileExists(strPath & strFileName & Chr(46) & strExtension) = True
strFileName = Left(strFileName, lng_Name) & "(" & lng_F & ")"
lng_F = lng_F + 1
Loop
'Reassemble the filename
FileNameUnique = strFileName
lbl_Exit:
Set FSO = Nothing
Exit Function
End Function
Private Sub CreateFolders(strPath As String)
'A Graham Mayor/Greg Maxey AddIn Utility Macro
Dim oFSO As Object
Dim lng_PathSep As Long
Dim lng_PS As Long
If Right(strPath, 1) <> "\" Then strPath = strPath & "\"
lng_PathSep = InStr(3, strPath, "\")
If lng_PathSep = 0 Then GoTo lbl_Exit
Set oFSO = CreateObject("Scripting.FileSystemObject")
Do
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
If lng_PathSep = 0 Then Exit Do
If Len(Dir(Left(strPath, lng_PathSep), vbDirectory)) = 0 Then Exit Do
Loop
Do Until lng_PathSep = 0
If Not oFSO.FolderExists(Left(strPath, lng_PathSep)) Then
oFSO.CreateFolder Left(strPath, lng_PathSep)
End If
lng_PS = lng_PathSep
lng_PathSep = InStr(lng_PS + 1, strPath, "\")
Loop
lbl_Exit:
Set oFSO = Nothing
Exit Sub
End Sub