Sub MergeToSplitLine()


    'Merges one record at a time to the chosen output folder
'Application.ScreenUpdating = False
Dim StrFolder As String, StrName As String, MainDoc As Document, i As Long, istart As Long, thisSet As String
Set MainDoc = ActiveDocument
With MainDoc
StrFolder = .Path & "\"

.MailMerge.DataSource.ActiveRecord = 1
thisSet = .MailMerge.DataSource.DataFields("Line").Value
StrName = thisSet & " _ " & .MailMerge.DataSource.DataFields("Part")
istart = 1
'MsgBox "start"

  For i = 1 To .MailMerge.DataSource.RecordCount
    
    
    
    If i < .MailMerge.DataSource.RecordCount Then
    .MailMerge.DataSource.ActiveRecord = i + 1
        If thisSet = .MailMerge.DataSource.DataFields("Line").Value Then
        GoTo skipOutput
        End If
    End If

        With .MailMerge
          .Destination = wdSendToNewDocument
          .SuppressBlankLines = True
          With .DataSource
            .FirstRecord = istart
            .LastRecord = i
          End With
          .Execute Pause:=False
        End With
        With ActiveDocument
          .SaveAs2 FileName:=StrFolder & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
          .Close SaveChanges:=False
        End With
        If i < .MailMerge.DataSource.RecordCount Then
            istart = i + 1
            .MailMerge.DataSource.ActiveRecord = i + 1
            thisSet = .MailMerge.DataSource.DataFields("Line").Value
            StrName = thisSet & " _ " & .MailMerge.DataSource.DataFields("Part")
        End If
skipOutput:
    
    DoEvents
   
  Next i
End With


Application.ScreenUpdating = True