I had another quick look and made a few changes that 'might' happen to work. If this still doesn't do it and you want someone to take a more considered look at the code, attach a merge docx and data source that we can test the code with.
Code:
Sub MailMergeToDoc()
Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, j As Long
Const StrNoChr As String = """*./\:?|"
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & ""
StrFolder = Replace(StrFolder, "TEMPLATES for ", "")
With .MailMerge
.Destination = wdSendToNewDocument
.SuppressBlankLines = True
On Error Resume Next
If .DataSource.RecordCount = 0 Then Exit Sub 'added this line
For i = 1 To .DataSource.RecordCount
With .DataSource
.FirstRecord = i
.LastRecord = i
.ActiveRecord = i
If Trim(.DataFields("Property")) = "" Then Exit For
StrName = .DataFields("Property") & " - " & .DataFields("Formated_Date") & " " & .DataFields("Premises_")
End With
On Error GoTo NextRecord
.Execute Pause:=False
' skip over unticked rejections
' If Err.Number = 5631 Then Err.Clear 'line disabled
GoTo NextRecord
For j = 1 To Len(StrNoChr)
StrName = Replace(StrName, Mid(StrNoChr, j, 1), "_")
Next
StrName = Trim(StrName)
With ActiveDocument
'Add the name to the footer
'.Sections(1).Footers(wdHeaderFooterPrimary).Range .InsertBefore StrName
' SaveAs FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
' and/or:
.SaveAs FileName:=StrFolder & StrName & ".pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
.Close SaveChanges:=False
End With
NextRecord:
If .DataSource.ActiveRecord = .DataSource.LastRecord Then Exit For 'added this line
Next i 'THIS IS WHERE COMPILE ERROR HAPPENS IF ONLY ONE RECORD'
End With
End With
Application.ScreenUpdating = True
End Sub