Sub Demo()
'Application.ScreenUpdating = False
Dim r As Long, c As Long
Dim l As Integer
Dim theNewRow As Row
Dim oSec As Section
Dim newPage As Section


'Cria um novo documento Word
Set oDoc = ActiveDocument
Set oTarget = Documents.Add
Set newPage = ActiveDocument.Sections.Add

'Cria uma nova tabela Word
oTarget.Tables.Add Range:=Selection.Range, NumRows:=2, NumColumns:= _
4, DefaultTableBehavior:=wdWord9TableBehavior, AutoFitBehavior:= _
wdAutoFitFixed

'Formata esta nova tabela

With ActiveDocument.Tables(1)
    .Cell(1, 1).Range.Text = "ISARP"
    .Cell(1, 2).Range.Text = "ITEM"
    .Cell(1, 3).Range.Text = "SESSION"
    .Cell(1, 4).Range.Text = "PAGE"
    
    .Columns(1).SetWidth ColumnWidth:=CentimetersToPoints(2.5), rulerstyle:=wdAdjustFirstColumn
    .Columns(2).SetWidth ColumnWidth:=CentimetersToPoints(8.1), rulerstyle:=wdAdjustFirstColumn
    .Columns(3).SetWidth ColumnWidth:=CentimetersToPoints(2.7), rulerstyle:=wdAdjustFirstColumn
    .Columns(4).SetWidth ColumnWidth:=CentimetersToPoints(1.7), rulerstyle:=wdAdjustFirstColumn
End With


l = 2

oDoc.Activate
With ActiveDocument.Range
  With .Find
    .Text = "IOSA"
    .Execute
  End With



Do While .Find.Found
    If .Information(wdWithInTable) = True Then
    nTabelasOrigem = ActiveDocument.Range(0, Selection.Tables(1).Range.End).Tables.Count
    Set theNewRow = ActiveDocument.Tables(nTabelasOrigem).Rows.Add
      t = ActiveDocument.Range(0, Selection.Tables(nTabelasOrigem).Range.End).Tables.Count
      r = .Cells(1).RowIndex
      c = .Cells(1).ColumnIndex
      d = oDoc.Tables(t).Cell(r, c).Range.Information(wdActiveEndPageNumber)
      e = oDoc.Range.GoTo(What:=wdGoToPage, Name:=d).Sections.First.Headers(wdHeaderFooterPrimary).Range.Text

    oTarget.Activate
      a = oDoc.Tables(t).Cell(r, c).Range.Text
      b = oDoc.Tables(t).Cell(r, c - 1).Range.Text

      With ActiveDocument.Tables(1).Rows(l)
        .Cells(1).Range.Text = a
        .Cells(2).Range.Text = b
        .Cells(3).Range.Text = e
        .Cells(4).Range.Text = d
      End With
      
l = l + 1

    End If
    .Collapse wdCollapseEnd
    .Find.Execute
  Loop
End With
'Application.ScreenUpdating = True
End Sub