Here is the text, originally courtesy of Gregory Maxey but customised to my
own purpose: Option Explicit
Private oUF2 As Advanced
Private AdvOption As Long
Private TextMark As String
Private Sub CheckBox2_Click()
 If CheckBox2.Value = -1 Then
   TextBox1.Enabled = True
 Else
   TextBox1.Enabled = False
 End If
End Sub
Private Sub CheckBox4_Click()
If ActiveDocument.Tables.Count > 0 Then
 Set oUF2 = New Advanced
 Load oUF2
 oUF2.Show vbModal
 TextMark = oUF2.TextMark
 AdvOption = CLng(oUF2.Frame1.Tag)
 Unload oUF2
 Set oUF2 = Nothing
End If
End Sub
Private Sub CheckBox8_Click()
'If System.PrivateProfileString("", _
'   "HKEY_CURRENT_USER\Software\Microsoft\" _
'   & "Office\11.0\Word\Options", "CleanUpText") <> "DoNotShow" Then
'  Me.Hide
'  Dim oUF2 As UserTip
'  Set oUF2 = New UserTip
'  Load oUF2
'  oUF2.Show vbModal
'  Unload oUF2
'  Set oUF2 = Nothing
'End If
End Sub
Private Sub CommandButton1_Click()

Dim oRng As Word.Range
Dim bParaAdded As Boolean
Dim pWrap As Integer
Dim pStoryType As Integer

'TextMark = oUF2.TextMark
'AdvOption = CLng(oUF2.Frame1.Tag)
'  Unload oUF2
'  Set oUF2 = Nothing
Me.Hide
Word.Application.ScreenUpdating = False

If OptionButton1.Value = -1 Then
 Set oRng = Selection.Range
 'Ensure proper paragraph marks
 pStoryType = oRng.StoryType
 pWrap = 0
 If oRng.Paragraphs.Count > 1 Then
   ValidateParagraphs oRng, pWrap
   If oRng.End = ActiveDocument.StoryRanges(pStoryType).End Then
     oRng.Paragraphs.Last.Range.Delete
   End If
 End If
 Set oRng = Nothing
 If Selection.Range.Start = ActiveDocument.StoryRanges(pStoryType).Start Then
   Selection.InsertBefore Chr(13)
   bParaAdded = True
 ElseIf Selection.Start <> Selection.Paragraphs(1).Range.Start Then
   Selection.MoveStart Unit:=wdLine, Count:=-1
   Selection.MoveStart Unit:=wdCharacter, Count:=-1
 Else
   Selection.MoveStart Unit:=wdCharacter, Count:=-1
 End If
 Set oRng = Selection.Range
 pWrap = 0
 'Call Processor
 Process oRng, pWrap, bParaAdded, pStoryType
ElseIf OptionButton2.Value = -1 Then
 Set oRng = Selection.Range
 oRng.WholeStory
 pStoryType = oRng.StoryType
 pWrap = 1
 'Ensure proper paragraph marks
  If oRng.Paragraphs.Count > 1 Then
   ValidateParagraphs oRng, pWrap
   ActiveDocument.StoryRanges(pStoryType).Paragraphs.Last.Range.Delete
 End If
 ActiveDocument.StoryRanges(pStoryType).InsertBefore Chr(13)
 pWrap = 1
 bParaAdded = True
 'Call Processor
 Process oRng, pWrap, bParaAdded, pStoryType
Else
 MakeHFValid
 For Each oRng In ActiveDocument.StoryRanges
   If oRng.StoryLength >= 2 Then 'Skips empty/near empty storyranges
   pStoryType = oRng.StoryType
   pWrap = 1
   Do
     'Ensure proper paragraph marks
     If oRng.Paragraphs.Count > 1 Then
       ValidateParagraphs oRng, pWrap
       oRng.Paragraphs.Last.Range.Delete
     End If
     oRng.InsertBefore Chr(13)
     pWrap = 1
     bParaAdded = True
     'Call Processor
     Process oRng, pWrap, bParaAdded, pStoryType
     Set oRng = oRng.NextStoryRange
   Loop Until oRng Is Nothing
   End If
 Next
End If
'Me.Hide
Word.Application.ScreenRefresh
Word.Application.ScreenUpdating = True
Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
       .Text = "  "
       .Replacement.Text = ""
       .Forward = True
       .Wrap = wdFindContinue
       .Format = False
       .MatchCase = False
       .MatchWholeWord = False
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
   Selection.Find.ClearFormatting
   Selection.Find.Replacement.ClearFormatting
   With Selection.Find
       .Text = ": "
       .Replacement.Text = ":"
       .Forward = True
       .Wrap = wdFindContinue
       .Format = False
       .MatchCase = False
       .MatchWholeWord = False
       .MatchWildcards = False
       .MatchSoundsLike = False
       .MatchAllWordForms = False
   End With
   Selection.Find.Execute Replace:=wdReplaceAll
End Sub
Private Sub CommandButton2_Click()
Me.Hide
End Sub
Private Sub CommandButton3_Click()
Me.Hide
Dim oUF1 As Tips
Set oUF1 = New Tips
Load oUF1
oUF1.Show vbModal
Unload oUF1
Set oUF1 = Nothing
End Sub

Private Sub UserForm_Initialize()
OptionButton3.Value = True
TextBox1.Enabled = False
CheckBox1.Value = True
CheckBox3.Value = True
CheckBox8.Value = True
CheckBox4.Value = True
CheckBox7.Value = True
End Sub
Private Sub Process(ByRef oRng As Range, ByVal pWrap As Integer, _
                   ByVal bParaAdded As Boolean, ByVal pStoryType As Integer)

Dim TextCharArray As Variant
Dim i As Integer
Dim j As Integer
Dim EP As Range
Dim oPara As Paragraph

If CheckBox1.Value = -1 Then
 With oRng.Find
   .ClearFormatting
   .Replacement.ClearFormatting
   .Forward = True
   .Wrap = pWrap
   .MatchWildcards = True
   For i = 1 To 8
     Select Case i
       Case 1
         .Text = "(^13)( {1,})"
         .Replacement.Text = "\1"
       Case 2
         .Text = "(^l)( {1,})"
         .Replacement.Text = "\1"
       Case 3
         .Text = "( {1,})(^13)"
         .Replacement.Text = "\2"
       Case 4
         .Text = "( {1,})(^l)"
         .Replacement.Text = "\2"
       Case 5
         .Text = "(^13)(^s{1,})"
         .Replacement.Text = "\1"
       Case 6
         .Text = "(^l)(^s{1,})"
         .Replacement.Text = "\1"
       Case 7
         .Text = "(^s{1,})(^13)"
         .Replacement.Text = "\2"
       Case 8
         .Text = "(^s{1,})(^l)"
         .Replacement.Text = "\2"
       Case Else
         Exit For
     End Select
     .Execute Replace:=wdReplaceAll
   Next
 End With
End If

If CheckBox2.Value = -1 Then
   TextCharArray = Split(TextBox1, "|")
    With oRng.Find
     .ClearFormatting
     .Replacement.ClearFormatting
     .Forward = True
     .Wrap = pWrap
     .MatchWildcards = True
   For j = 0 To UBound(TextCharArray)
     If InStr("*(){}[]!@?", TextCharArray(j)) > 0 Then
       .MatchWildcards = True
       .Text = "(^13)\" & TextCharArray(j) & "{1,}"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = "\" & TextCharArray(j) & "{1,}(^13)"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = "(^l)\" & TextCharArray(j) & "{1,}"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = "\" & TextCharArray(j) & "{1,}(^l)"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
     ElseIf InStr("<>", TextCharArray(j)) > 0 Then
       .MatchWildcards = True
       .Text = "(^13)[\" & TextCharArray(j) & "]{1,}"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = "[\" & TextCharArray(j) & "]{1,}(^13)"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = "(^l)[\" & TextCharArray(j) & "]{1,}"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = "[\" & TextCharArray(j) & "]{1,}(^l)"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
     Else
       .MatchWildcards = True
       .Text = "(^13)" & TextCharArray(j) & "{1,}"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = TextCharArray(j) & "{1,}(^13)"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = "(^l)" & TextCharArray(j) & "{1,}"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
       .Text = TextCharArray(j) & "{1,}(^l)"
       .Replacement.Text = "\1"
       .Execute Replace:=wdReplaceAll
     End If
   Next j
 End With
End If

If CheckBox1.Value = -1 Then
 With oRng.Find
   .ClearFormatting
   .Replacement.ClearFormatting
   .Forward = True
   .Wrap = pWrap
   .MatchWildcards = True
   For i = 1 To 8
     Select Case i
       Case 1
         .Text = "(^13)( {1,})"
         .Replacement.Text = "\1"
       Case 2
         .Text = "(^l)( {1,})"
         .Replacement.Text = "\1"
       Case 3
         .Text = "( {1,})(^13)"
         .Replacement.Text = "\2"
       Case 4
         .Text = "( {1,})(^l)"
         .Replacement.Text = "\2"
       Case 5
         .Text = "(^13)(^s{1,})"
         .Replacement.Text = "\1"
       Case 6
         .Text = "(^l)(^s{1,})"
         .Replacement.Text = "\1"
       Case 7
         .Text = "(^s{1,})(^13)"
         .Replacement.Text = "\2"
       Case 8
         .Text = "(^s{1,})(^l)"
         .Replacement.Text = "\2"
        Case Else
         Exit For
     End Select
     .Execute Replace:=wdReplaceAll
   Next
 End With
End If
'Replace line breaks with paragraph formatting
If CheckBox3.Value = -1 Then
 With oRng.Find
   .ClearFormatting
   .Replacement.ClearFormatting
   .Forward = True
   .Wrap = pWrap
   .MatchWildcards = True
   For i = 1 To 2
     Select Case i
     Case 1
       .Text = "^l{2,}"
       .Replacement.Text = "^p"
     Case 2
       .Text = "^l{1,}"
       .Replacement.Text = " "
     Case Else
       Exit For
     End Select
     .Execute Replace:=wdReplaceAll
   Next
 End With
End If
'Remove carriage returns at end of each line.
If CheckBox8.Value = -1 Then
 With oRng.Find
   .Text = "([!^13])(^13)([!^13])"
   .Replacement.Text = "\1 \3"
   .Forward = True
   .Wrap = pWrap
   .MatchWildcards = True
   .Execute Replace:=wdReplaceAll
 End With
 With oRng.Find
   .Text = "^13{2,}"
   .Replacement.Text = "^p"
   .Forward = True
   .Wrap = pWrap
   .MatchWildcards = True
   .Execute Replace:=wdReplaceAll
 End With
End If

'Remove Empty Paragraphs
If CheckBox4.Value = -1 Then
 With oRng.Find
   .Text = "^13{2,}"
   .Replacement.Text = "^p"
   .Forward = True
   .Wrap = pWrap
   .MatchWildcards = True
   .Execute Replace:=wdReplaceAll
 End With
 If AdvOption = 2 Then
   For Each oPara In oRng.Paragraphs
     If Len(oPara.Range.Text) = 1 Then
       oPara.Range.Delete
     End If
   Next
 Else
 'Call Macro to process empty PMs in tables and nested tables
   ProcessTables oRng, pStoryType
 End If
 If oRng.Paragraphs.Count > 1 Then
   Set EP = ActiveDocument.StoryRanges(pStoryType).Paragraphs.First.Range
   If EP.Text = vbCr Then EP.Delete
   Set EP = ActiveDocument.StoryRanges(pStoryType).Paragraphs.Last.Range
   If EP.Text = vbCr Then EP.Delete
 End If
ElseIf bParaAdded = True Then
 oRng.Paragraphs(1).Range.Delete
End If

'Clear Formatting
If CheckBox5.Value = -1 Then oRng.Font.Reset
If CheckBox6.Value = -1 Then oRng.ParagraphFormat.Reset
If CheckBox7.Value = -1 Then
 oRng.Style = ActiveDocument.Styles(wdStyleNormal)
End If
If oRng.Paragraphs.Last.Range.Characters.Count = 1 Then
  On Error Resume Next
  oRng.Paragraphs.Last.Range.Delete
  On Error GoTo 0
End If
Selection.Collapse Direction:=wdCollapseStart
End Sub
Private Sub ValidateParagraphs(ByVal oRng As Range, pWrap As Integer)
With oRng.Find
 .ClearFormatting
 .Replacement.ClearFormatting
 .Forward = True
 .Wrap = pWrap
 .Text = "^13"
 .Replacement.Text = "^p"
 .Execute Replace:=wdReplaceAll
End With
End Sub
Private Sub MakeHFValid()
Dim lngJunk As Long
lngJunk = ActiveDocument.Sections(1).Headers(1).Range.StoryType
End Sub
Sub ProcessTables(oRng As Range, pStoryType As Integer)
Dim TopTable As Table
Dim ttCell As Word.Cell
Dim Level As Long
Dim Level2Table As Word.Table

For Each TopTable In oRng.Tables
 'Call Macro to process empty PMs between top level tables
 BAITables TopTable, pStoryType
 
 Level = 1
 'Call Macro to process empty PMs in TopTable cells
 ProcessCells TopTable, pStoryType
 
 'Process TopTable for nested tables
 For Each ttCell In TopTable.Range.Cells
   If ttCell.Tables.Count > 0 Then
     Dim j As Integer
     For j = 1 To ttCell.Tables.Count
       Set Level2Table = ttCell.Tables(j)
       Level = 2
       'Process cells in Level2 Tables
       ProcessCells Level2Table, pStoryType
       'Process deep nested Tables
       ProcessNestedTable Level, Level2Table, TopTable, pStoryType
     Next
   End If
 Next ttCell
Next
End Sub
Function ProcessNestedTable(NewLevel As Long, _
   tbl As Word.Table, ByRef tblOuter As Word.Table, pStoryType As Integer)

Dim celNested As Word.Cell
Dim tblNested As Word.Table

For Each celNested In tbl.Range.Cells
 If celNested.Tables.Count > 0 Then
   Set tblNested = celNested.Tables(1)
   NewLevel = tblNested.NestingLevel
   Set tblOuter = tblNested
   ProcessCells tblNested, pStoryType
   ProcessNestedTable NewLevel, tblNested, tblOuter, pStoryType
 End If
Next celNested
End Function
Sub BAITables(oTbl As Table, pStoryType As Integer)

Dim myRange As Range
Dim emptyPara As Boolean

'Remove empty PMs immediate before, after, and between
'top level tables
Set myRange = oTbl.Range 'tbl.Range
myRange.Collapse wdCollapseEnd
If myRange.Paragraphs(1).Range.Text = vbCr Then
 myRange.Collapse wdCollapseEnd
 myRange.Move wdParagraph, 1
 If myRange.Information(wdWithInTable) Then
   'Do nothing.  Issue will be resolve while
   'processing next table.
 Else
   myRange.Move wdParagraph, -1
   myRange.Paragraphs(1).Range.Delete
 End If
End If
Set myRange = oTbl.Range
Do
 myRange.Collapse wdCollapseStart
 myRange.Move wdParagraph, -1
 If myRange.Paragraphs(1).Range.Text = vbCr Then
   myRange.Collapse wdCollapseStart
   If myRange.Start = ActiveDocument.StoryRanges(pStoryType).Start Then
     myRange.Paragraphs(1).Range.Delete
     emptyPara = False
   Else
     myRange.Move wdParagraph, -1
     If myRange.Information(wdWithInTable) Then
       If AdvOption = 3 Then
         myRange.Move wdParagraph, 1
         emptyPara = True
         myRange.Text = TextMark '"****"
       End If
     Else
       myRange.Move wdParagraph, 1
       emptyPara = True
       myRange.Paragraphs(1).Range.Delete
     End If
   End If
 Else
   emptyPara = False
 End If
Loop While emptyPara = True

End Sub
Sub ProcessCells(tbl As Table, ByVal pStoryType As Integer)
Dim oCell As Cell
Dim Counter As Integer
Dim oPara As Paragraph
Dim workingRng As Range
Dim prevTab As Range
Dim k As Integer
Dim emptyPara As Boolean

For Each oCell In tbl.Range.Cells
 If oCell.Tables.Count > 1 Then
   'Process PMs before first table
   Set workingRng = oCell.Tables(1).Range
   Do
     workingRng.Collapse wdCollapseStart
     workingRng.Move wdParagraph, -1
     If workingRng.Paragraphs(1).Range.Text = vbCr Then
       workingRng.Paragraphs(1).Range.Delete
       emptyPara = True
     Else
        emptyPara = False
     End If
   Loop While emptyPara = True
   
   For k = 2 To oCell.Tables.Count
     Set workingRng = oCell.Tables(k).Range
     'Process PM after last table
     If k = oCell.Tables.Count Then
       workingRng.Collapse wdCollapseEnd
       If workingRng.Paragraphs(1).Range.Text = vbCr Then
         workingRng.Paragraphs(1).Range.Delete
       End If
       Set workingRng = oCell.Tables(k).Range
     End If
     'Process PMs preceeding remaining tables
     Set prevTab = oCell.Tables(k - 1).Range
     workingRng.Select
     Do
       workingRng.Collapse wdCollapseStart
       workingRng.Move wdParagraph, -1
       If workingRng.Paragraphs(1).Range.Text = vbCr Then
         workingRng.Collapse wdCollapseStart
         workingRng.Move wdParagraph, -1
         If workingRng.InRange(prevTab) Then
           If AdvOption = 3 Then
             workingRng.Move wdParagraph, 1
             emptyPara = True
             workingRng.Text = TextMark '"****"
           End If
         Else
           workingRng.Move wdParagraph, 1
           emptyPara = True
           workingRng.Paragraphs(1).Range.Delete
         End If
       Else
         emptyPara = False
       End If
     Loop While emptyPara = True
   Next
 Else
   For Each oPara In oCell.Range.Paragraphs
     If oPara.Range.Characters(1).Text = vbCr Then
       oPara.Range.Delete
     End If
   Next
   If Len(oCell.Range.Text) > 2 And _
        Asc(Right$(oCell.Range.Text, 3)) = 13 Then
     oCell.Range.Characters(Len(oCell.Range.Text) - 2).Delete
   End If
 End If
Next
End Sub

Pete,

If you can send me you customized template and a sample document where it is
failing, I will see if I can figure out what is going wrong.

I just ran the AddIn here on a Word2007 document and it ran without
problems.

You can use the feedback link on my website to contact me via e-mail,