View Single Post
 
Old 08-29-2024, 03:39 PM
Guessed's Avatar
Guessed Guessed is offline Windows 10 Office 2016
Expert
 
Join Date: Mar 2010
Location: Canberra/Melbourne Australia
Posts: 4,158
Guessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant futureGuessed has a brilliant future
Default

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
__________________
Andrew Lockton
Chrysalis Design, Melbourne Australia
Reply With Quote