Sub CleanupTables2()
  Dim aTbl    As Table
  Dim aRng    As Range
  Dim aRow    As Row
  Dim aRng2    As Range
  Dim dblEnd As Double
  Dim aCell As Cell
  Dim iCounter As Integer
  
  On Error GoTo errHandle
  
  For iCounter = 1 To ActiveDocument.Tables.Count
    Set aTbl = ActiveDocument.Tables(iCounter)
    Set aRng = aTbl.Range
    aRng.MoveStart Unit:=wdParagraph, Count:=-1
    aRng.Select
    ActiveWindow.ScrollIntoView aRng, True
    With aTbl
      If MsgBox("Does this table have a table name", vbYesNo) = vbYes Then
        dblEnd = aTbl.Range.End
        aTbl.Rows.Add
        Set aRng2 = ActiveDocument.Range(dblEnd, aTbl.Range.End)
        aRng2.Cells.Merge
        Set aRng2 = ActiveDocument.Range(aTbl.Range.Start, dblEnd)
        aRng2.Relocate Direction:=wdRelocateDown
        Set aRng = aRng.Paragraphs(1).Range
        aRng.MoveEnd Unit:=wdCharacter, Count:=-1
        Set aCell = aTbl.Cell(1, 1)
        aCell.Range.FormattedText = aRng.FormattedText
        aRng.Paragraphs(1).Range.Delete
        aCell.Borders(wdBorderTop).LineStyle = wdLineStyleNone
        aCell.Borders(wdBorderLeft).LineStyle = wdLineStyleNone
        aCell.Borders(wdBorderRight).LineStyle = wdLineStyleNone
        aCell.Range.Style = "Caption"
        aCell.Range.ParagraphFormat.Reset
      End If
    End With
NextTable:
  Next iCounter
  
  Exit Sub

errHandle:
  MsgBox "Error " & Err.Number & ": " & Err.Description & " in selected table"
  aTbl.Range.HighlightColorIndex = wdPink
  Resume NextTable
End Sub