Better done with a report in Access.  However you may be able to modify the
following to do what you want or

See the "Multiple items per condition" item under the "Special merges"
section of fellow MVP CIndy Meister's website at

http://homepage.swissonline.ch/cindymeister/MergFram.htm

' Macro to create multiple items per condition in separate tables from a
directory type mailmerge

Dim source As Document, target As Document, scat As Range, tcat As Range

Dim data As Range, stab As Table, ttab As Table

Dim i As Long, j As Long, k As Long, n As Long

Set source = ActiveDocument

Set target = Documents.Add

Set stab = source.Tables(1)

k = stab.Columns.Count

Set ttab = target.Tables.Add(Range:=Selection.Range, numrows:=1,
numcolumns:=k - 1)

Set scat = stab.Cell(1, 1).Range

scat.End = scat.End - 1

ttab.Cell(1, 1).Range = scat

j = ttab.Rows.Count

For i = 1 To stab.Rows.Count

   Set tcat = ttab.Cell(j, 1).Range

   tcat.End = tcat.End - 1

   Set scat = stab.Cell(i, 1).Range

   scat.End = scat.End - 1

   If scat <> tcat Then

       ttab.Rows.Add

       j = ttab.Rows.Count

       ttab.Cell(j, 1).Range = scat

       ttab.Cell(j, 1).Range.Paragraphs(1).PageBreakBefore = True

       ttab.Rows.Add

       ttab.Cell(j + 1, 1).Range.Paragraphs(1).PageBreakBefore = False

       For n = 2 To k

           Set data = stab.Cell(i, n).Range

           data.End = data.End - 1

           ttab.Cell(ttab.Rows.Count, n - 1).Range = data

       Next n

   Else

       ttab.Rows.Add

       For n = 2 To k

           Set data = stab.Cell(i, n).Range

           data.End = data.End - 1

           ttab.Cell(ttab.Rows.Count, n - 1).Range = data

       Next n

   End If

Next i