Option Explicit

Sub PLR()
'Macro by Graham Mayor 2015
Dim oSource As Document
Dim oTarget As Document
Dim oTable As Table
Dim oRow As Row
Dim oCell As Range
Dim oPara As Range
Dim i As Long
    Set oSource = ActiveDocument
    Set oTarget = Documents.Add
    'Setup the table document
    oTarget.PageSetup.PaperSize = wdPaperLetter
    oTarget.PageSetup.Orientation = wdOrientLandscape
    oTarget.PageSetup.LeftMargin = InchesToPoints(0.35)
    oTarget.PageSetup.RightMargin = InchesToPoints(0.25)
    'Setup the table size
    Set oTable = oTarget.Tables.Add(oTarget.Range, 1, 3)
    With oTable
        .Style = "Table Grid"
        .ApplyStyleHeadingRows = True
        .ApplyStyleLastRow = False
        .ApplyStyleFirstColumn = True
        .ApplyStyleLastColumn = False
        .ApplyStyleRowBands = True
        .ApplyStyleColumnBands = False
        .AllowAutoFit = False
        .Columns(1).SetWidth _
                ColumnWidth:=206, _
                RulerStyle:=wdAdjustNone
        .Columns(2).SetWidth _
                ColumnWidth:=206, _
                RulerStyle:=wdAdjustNone
        .Columns(3).SetWidth _
                ColumnWidth:=338, _
                RulerStyle:=wdAdjustNone
    End With
    On Error GoTo lbl_Exit
    For i = 1 To oSource.Paragraphs.Count Step 5
        Set oRow = oTable.Rows.Last
        Set oPara = oSource.Paragraphs(i).Range
        'Process column 3
        Set oCell = oRow.Cells(3).Range
        oCell.End = oCell.End - 1
        oCell.FormattedText = oPara.FormattedText
        Set oPara = oSource.Paragraphs(i + 3).Range
        oPara.End = oPara.End - 1
        oCell.Collapse 0
        oCell.Text = "Add some text" & vbCr
        oCell.Collapse 0
        oCell.FormattedText = oPara.FormattedText

        'Process column 2
        Set oCell = oRow.Cells(2).Range
        oCell.End = oCell.End - 1
        Set oPara = oSource.Paragraphs(i + 4).Range
        oCell.FormattedText = oPara.FormattedText

        'Process column 1
        Set oCell = oRow.Cells(1).Range
        oCell.End = oCell.End - 1
        Set oPara = oSource.Paragraphs(i + 2).Range
        oCell.FormattedText = oPara.FormattedText
        oCell.Collapse 0
        Set oPara = oSource.Paragraphs(i + 1).Range
        oPara.End = oPara.End - 1
        oCell.FormattedText = oPara.FormattedText
        'If not the end of the list add a row
        'Assumes no blank paragraphs at the end
        If i < oSource.Paragraphs.Count - 4 Then oTable.Rows.Add
        DoEvents
    Next i
    'Format the table
    With oTable
        .Range.Font.name = "Palatino Linotype"
        .Range.Font.Size = 12
        .Range.ParagraphFormat.SpaceAfter = 0
        .Range.LanguageID = wdEnglishUS
    End With
lbl_Exit:
    'Clean up
    Set oSource = Nothing
    Set oTarget = Nothing
    Set oTable = Nothing
    Set oRow = Nothing
    Set oCell = Nothing
    Set oPara = Nothing
    Exit Sub
End Sub