Sub ExtractTableNotes()
Application.ScreenUpdating = False
Dim i As Long, Rng As Range
With ActiveDocument
  For i = .Tables.Count To 1 Step -1
    If i = 1 Then
      If .Tables(i).Range.Start = .Range.Start Then
        Set Rng = .Tables(i).Range
        With Rng
          .Tables(i).Range.Cut
          .InsertBefore vbCr
          .Collapse wdCollapseEnd
          .Paste
        End With
      End If
    End If
    Set Rng = .Tables(i).Range.Cells(1).Range
    If InStr(Rng.Text, "Listing") > 0 Then
      With Rng
        .End = .End - 1
        .InsertAfter vbCr
        .Copy
        .Start = .Start - 1
        .Collapse wdCollapseStart
        .InsertAfter vbCr
        .Collapse wdCollapseEnd
        .Paste
        .Characters.Last.Delete
      End With
    End If
    Set Rng = .Tables(i).Range.Cells(.Tables(i).Range.Cells.Count).Range
    With Rng
      .End = .End - 1
      .InsertAfter vbCr
      .Copy
    End With
    Set Rng = .Tables(i).Range
    Rng.Tables(1).Delete
    Rng.Paste
  Next
End With
Application.ScreenUpdating = True
End Sub