Sub MailMergeToDoc()
Application.ScreenUpdating = False
Dim s As Long, c As Long, r As Long, t As Long
Dim Tbl As Table, StrRDt As String, StrCDt As String, Rng As Range
Dim u As Long, v As Long, w As Long, x As Long
ActiveDocument.MailMerge.Execute
With ActiveDocument
  For s = 1 To .Sections.Count ' - 1
    Set Tbl = .Sections(s).Range.Tables(1)
    With Tbl
      .Range.ParagraphFormat.Alignment = wdAlignParagraphRight
      .Rows.Alignment = wdAlignRowCenter
      .Rows(1).HeadingFormat = True
      .Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
      For c = 3 To 5
        .Columns(c).PreferredWidthType = wdPreferredWidthPoints
        .Columns(c).PreferredWidth = InchesToPoints(1)
      Next
      StrRDt = Split(.Cell(.Rows.Count, 1).Range.Text, vbCr)(0)
      StrRDt = Split(StrRDt, "-")(1) & "-" & Split(StrRDt, "-")(2)
      .Rows.Add: t = .Rows.Count
      For r = t - 1 To 2 Step -1
        StrCDt = Split(.Cell(r, 1).Range.Text, vbCr)(0)
        StrCDt = Split(StrCDt, "-")(1) & "-" & Split(StrCDt, "-")(2)
        If StrRDt = StrCDt Then
          For c = 3 To 5
            Select Case c
              Case 3: u = u + Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
              Case 4: v = v + Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
              Case 5: w = w + Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
            End Select
          Next
        ElseIf (StrRDt <> StrCDt) Or (r = 2) Then
          .Cell(t, 1).Range.Text = StrRDt
          .Rows(t).Range.Font.Italic = True
          For c = 3 To 5
            Select Case c
              Case 3
                .Cell(t, c).Range.Text = Format(u, "£#,##0")
                u = Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
              Case 4
                .Cell(t, c).Range.Text = Format(v, "£#,##0")
                v = Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
              Case 5
                .Cell(t, c).Range.Text = Format(w, "£#,##0")
                w = Split(Split(.Cell(r, c).Range.Text, vbCr)(0), "£")(1)
            End Select
          Next
          StrRDt = StrCDt: t = r + 1
          If r <> 2 Then
            .Rows.Add Tbl.Rows(r + 1)
          Else
            Exit For
          End If
        End If
      Next
      .Cell(t, 1).Range.Text = StrRDt
      For c = 3 To 5
        Select Case c
          Case 3
            .Cell(t, c).Range.Text = Format(u, "£#,##0")
          Case 4
            .Cell(t, c).Range.Text = Format(v, "£#,##0")
          Case 5
            .Cell(t, c).Range.Text = Format(w, "£#,##0")
        End Select
      Next
      .Rows(t).Range.Font.Italic = True
      .Rows.Add: t = .Rows.Count
      For c = 3 To 5
        Set Rng = .Cell(t, c).Range
        Rng.Collapse wdCollapseStart
        Rng.Fields.Add Rng, wdFieldEmpty, "=SUM(ABOVE)/2 \# £,#0", False
      Next
      .Cell(t, 1).Range.Text = "TOTAL:"
      .Rows(t).Range.Font.Bold = True
    End With
    Set Tbl = .Sections(s).Range.Tables(2)
    With Tbl
      .Range.ParagraphFormat.Alignment = wdAlignParagraphRight
      .Rows.Alignment = wdAlignRowCenter
      .Rows(1).HeadingFormat = True
      .Rows(1).Range.ParagraphFormat.Alignment = wdAlignParagraphCenter
      StrRDt = Split(.Cell(.Rows.Count, 1).Range.Text, vbCr)(0)
      StrRDt = Split(StrRDt, "-")(1) & "-" & Split(StrRDt, "-")(2)
      .Rows.Add: t = .Rows.Count
      For r = t - 1 To 2 Step -1
        StrCDt = Split(.Cell(r, 1).Range.Text, vbCr)(0)
        StrCDt = Split(StrCDt, "-")(1) & "-" & Split(StrCDt, "-")(2)
        If StrRDt = StrCDt Then
          x = x + Split(Split(.Cell(r, 2).Range.Text, vbCr)(0), "£")(1)
        ElseIf (StrRDt <> StrCDt) Or (r = 2) Then
          .Cell(t, 1).Range.Text = StrRDt
          .Rows(t).Range.Font.Italic = True
          .Cell(t, 2).Range.Text = Format(x, "£#,##0")
          StrRDt = StrCDt: t = r + 1
          If r <> 2 Then
            .Rows.Add Tbl.Rows(r + 1)
          Else
            Exit For
          End If
        End If
      Next
      .Cell(t, 1).Range.Text = StrRDt
      .Cell(t, 2).Range.Text = Format(x, "£#,##0")
      .Rows(t).Range.Font.Italic = True
      .Rows.Add: t = .Rows.Count
      Set Rng = .Cell(t, 2).Range
      Rng.Collapse wdCollapseStart
      Rng.Fields.Add Rng, wdFieldEmpty, "=SUM(ABOVE)/2 \# £,#0", False
      .Cell(t, 1).Range.Text = "TOTAL:"
      .Rows(t).Range.Font.Bold = True
    End With
  Next
  .Fields.Unlink
End With
Set Rng = Nothing: Set Tbl = Nothing
Application.ScreenUpdating = True
End Sub