Sub MailMergeToDoc()
Application.ScreenUpdating = False
Dim Rng As Range, t As Long, r As Long, c As Long, x As Long, y As Long
ActiveDocument.MailMerge.Execute
With ActiveDocument.Range
  For t = 1 To .Tables.Count
    With .Tables(t)
      .AllowAutoFit = False
      .Range.ParagraphFormat.Alignment = wdAlignParagraphRight
      .Rows.Alignment = wdAlignRowCenter
      .Rows(1).HeadingFormat = True
      .Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
      .Columns.PreferredWidthType = wdPreferredWidthPoints
      .Columns.PreferredWidth = InchesToPoints(0.625)
      .Columns(1).PreferredWidth = InchesToPoints(0.75)
      .Columns(10).PreferredWidth = InchesToPoints(0.75)
      Set Rng = .Rows(1).Range: r = .Rows.Count
      x = Split(Split(.Cell(r, 1).Range.Text, vbCr)(0), "-")(1)
      For r = .Rows.Count - 1 To 2 Step -1
        y = Split(Split(.Cell(r, 1).Range.Text, vbCr)(0), "-")(1)
        If x <> y Then
          .Split .Rows(r + 1): x = y
          With .Range.Characters.Last.Next
            .Collapse wdCollapseEnd
            .FormattedText = Rng.FormattedText
          End With
        End If
      Next
    End With
  Next
  Exit Sub
  For t = 1 To .Tables.Count
    With .Tables(t)
      .Rows.Add: r = .Rows.Count
      .Cell(r, 1).Range.Text = "TOTAL:"
      .Rows(r).Range.Font.Bold = True
      For c = 3 To 9
        Set Rng = .Cell(r, c).Range
        Rng.Collapse wdCollapseStart
        Rng.Fields.Add Rng, wdFieldEmpty, "=SUM(ABOVE) \# £,#0", False
      Next
    End With
  Next
  .Fields.Unlink
End With
Set Rng = Nothing
Application.ScreenUpdating = True
End Sub