For example:
Code:
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