Hi flds,
Try:
Code:
Sub Main()
Dim TOC As TableOfContents
With ActiveDocument
For Each TOC In .TablesOfContents
TOC.Delete
Next
.Fields.Unlink
Call MoveTablesToNewDocument
With .Content.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = "^b"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
.Text = "^~"
.Replacement.Text = "-"
.Execute Replace:=wdReplaceAll
End With
End With
End Sub
Code:
Sub MoveTablesToNewDocument()
Dim SrcDoc, NewDoc As Document
Dim SrcDocTableRange As Range
Set SrcDoc = ActiveDocument
If SrcDoc.Tables.Count <> 0 Then
Set NewDoc = Documents.Add(DocumentType:=wdNewBlankDocument)
Set NewDocRange = NewDoc.Range
Dim PrevPara As Range
Dim NextPara As Range
Dim NextEnd As Long
NextEnd = 0
With NewDocRange
For Each SrcDocTable In SrcDoc.Tables
Set SrcDocTableRange = SrcDocTable.Range
'output the preceding paragraph?
Set PrevPara = SrcDocTableRange.Previous(wdParagraph, 1)
If PrevPara Is Nothing Or PrevPara.Start < NextEnd Then
Else
Set PPWords = PrevPara.Words
If PPWords.Count > 1 Then 'yes
.Start = NewDocRange.End
.InsertParagraphBefore
.Start = NewDocRange.End
.InsertParagraphBefore
.FormattedText = PrevPara.FormattedText
End If
End If
'output the table
.Start = .End
.FormattedText = SrcDocTableRange.FormattedText
'output the following paragraph?
Set NextPara = SrcDocTableRange.Next(wdParagraph, 1)
If NextPara Is Nothing Then
Else
Set PPWords = NextPara.Words
NextEnd = NextPara.End
If PPWords.Count > 1 Then 'yes
.Start = .End
.InsertParagraphBefore
.FormattedText = NextPara.FormattedText
End If
End If
SrcDocTableRange.Delete
Next SrcDocTable
End With
End If
End Sub
PS: When posting code, please use code tags and formatted code.