View Single Post
 
Old 06-07-2011, 09:23 PM
macropod's Avatar
macropod macropod is offline Windows 7 32bit Office 2007
Administrator
 
Join Date: Dec 2010
Location: Canberra, Australia
Posts: 21,956
macropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond reputemacropod has a reputation beyond repute
Default

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.
__________________
Cheers,
Paul Edstein
[Fmr MS MVP - Word]

Last edited by macropod; 06-08-2011 at 09:55 PM. Reason: Minor code revision - TOC variable and loop in 1st module
Reply With Quote