Sub CleanupTables()
Application.ScreenUpdating = False
Dim Tbl As Table, Rng As Range, c As Long, s As Single, PrefWdthType As Long
For Each Tbl In ActiveDocument.Tables
  With Tbl
    PrefWdthType = .PreferredWidthType: s = 0
    Set Rng = .Range.Characters.First.Previous.Paragraphs.First.Range
    With Rng
      With Tbl.Range
        For c = 1 To .Cells.Count
          If .Cells(c).RowIndex = 1 Then
            s = s + .Cells(c).Width
          Else
            Exit For
          End If
        Next
      End With
      If .Text Like "Table [0-9]*" Then
        .Style = "Caption"
        .ParagraphFormat.Reset
        .End = .End - 1
        .ConvertToTable Separator:=vbTab, NumRows:=1, NumColumns:=1, Format:=wdTableFormatNone, ApplyHeadingRows:=True
        With .Tables(1)
          .PreferredWidthType = wdPreferredWidthPoints
          .PreferredWidth = s
          .Cell(1, 1).PreferredWidth = 0
          .Rows.LeftIndent = Tbl.Rows.LeftIndent
          .RightPadding = Tbl.LeftPadding
          .LeftPadding = Tbl.RightPadding
        End With
        .Characters.Last.Next.Text = vbNullString
        With .Tables(1)
          .PreferredWidthType = wdPreferredWidthPoints
          .PreferredWidth = s
          .Range.Cells.PreferredWidthType = PrefWdthType
          .PreferredWidthType = PrefWdthType
        End With
      End If
    End With
  End With
Next
Application.ScreenUpdating = True
End Sub