Sub DPU_DefinitionTabulator()
  Dim aRng As Range, aTbl As Table, aPara As Paragraph, aCell As Cell, oBorder As Border
    Application.ScreenUpdating = False
  Set aRng = ActiveDocument.Range
  For Each aPara In aRng.Paragraphs
    aPara.Range.Words.Last.Font.Reset     'remove bold from paragraph marks and autonumbers
  Next aPara
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "means "
    .Replacement.Text = "means "
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = ";" 'Remove bold format from semi-colons
    .Font.Bold = True
    .Replacement.Text = ";"
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll
    .Text = "." 'Remove bold format from period
    .Font.Bold = True
    .Replacement.Text = "."
    .Replacement.Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .ClearFormatting
    .Replacement.ClearFormatting
    .Font.Bold = True
    .Text = ""
    .Replacement.Text = "^&ZZENDBOLDZZ" 'Inserts a unique tag for bold words
    .Forward = True
    .Wrap = wdFindContinue
    .Format = True
    .MatchCase = False
    .MatchWholeWord = False
    .MatchAllWordForms = False
    .MatchSoundsLike = False
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll
    
    .ClearFormatting
    .Text = "[:;, ^t]{1,5}ZZENDBOLDZZ" 'Removes upto 5 instances of spaces/punctuation in front of zzEndBoldzz
    .Replacement.Text = "ZZENDBOLDZZ"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll

    .Text = "ZZENDBOLDZZ[:;, ^t]{1,5}" 'removes upto 5 instances of spaces/punctuation following zzEndBoldzz
    .Execute Replace:=wdReplaceAll
    
    .Text = "ZZENDBOLDZZmeans[:;, ^t]{1,5}" 'removes 'means' & trailing punctuation' if appears immediately after zzEndBoldzz
    .Execute Replace:=wdReplaceAll

    .Text = "[ ]{2,9}"          'multiple spaces reduced to one
    .Replacement.Text = " "
    .Execute Replace:=wdReplaceAll
       
    Set aRng = ActiveDocument.Range
    aRng.ListFormat.ConvertNumbersToText    'make lists hard coded
    
    .Text = "^w^p"             'paragraphs ending with whitespace have spaces removed
    .Replacement.Text = "^p"
    .MatchWildcards = False
    .Execute Replace:=wdReplaceAll

    .Text = ".^p"               'paragraphs ending with . add semi-colon
    .Replacement.Text = ";^p"
    .Execute Replace:=wdReplaceAll
    
     .Text = ".]^p"               'paragraphs ending with ] add semi-colon in front of ]
    .Replacement.Text = ";]^p"
    .Execute Replace:=wdReplaceAll
      
    .Text = " ([;:,]{1,5})"    'space before punctuation removed
    .Replacement.Text = "\1"
    .MatchWildcards = True
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13([A-Za-z0-9])\)"          'make sure lists with a) get opening bracket (a)
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13([A-Za-z0-9])."          'make sure lists with a. get brackets (a)
    .Replacement.Text = "^13(\1)"
    .Execute Replace:=wdReplaceAll
    
    .Text = "^13(?)"              'If paragraph starts non-bold
    '.Replacement.Text = "|\1"     'Option: keep all paragraphs in a definition in one row
    .Replacement.Text = "^p^t\1" 'Option: if you want separate rows per paragraph
    .MatchWildcards = True
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .Text = "([!^13])^t"                 'find tabs preceded by non-bold character other than a carriage return
    .Replacement.Text = "\1zzTabzz"      'replace with a replaceable unique string
    .Font.Bold = False
    .Execute Replace:=wdReplaceAll
    
    .ClearFormatting
    .Text = "ZZENDBOLDZZ^13^t" 'Removes unique tab and inserts tab
    .Replacement.Text = "^t"
    .Execute Replace:=wdReplaceAll
    
    .Text = "ZZENDBOLDZZ"
    .Replacement.Text = "^t" 'Removes unique tab and inserts tab
    .Execute Replace:=wdReplaceAll
    
  End With
  
  Set aRng = ActiveDocument.Range
  Set aTbl = aRng.ConvertToTable(Separator:=wdSeparateByTabs, NumColumns:=2, AutoFitBehavior:=wdAutoFitFixed)
  With aTbl
    .Style = "Table Grid Light"     'choose a table style that matches your preferred table look
    .ApplyStyleHeadingRows = False
    .ApplyStyleLastRow = False
    .ApplyStyleFirstColumn = True     'make sure table style has a bold first column
    .ApplyStyleLastColumn = False
    .ApplyStyleRowBands = False
    .Range.Style = "Definition Level 1"
    For Each aCell In .Columns(1).Cells
      aCell.Range.Style = "DefBold"
      If aCell.Range.Characters.First = "[" Then
        aCell.Range.Characters.First.InsertAfter Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      ElseIf Len(aCell.Range.Text) > 2 Then
        aCell.Range.Characters.First.InsertBefore Text:=""""
        aCell.Range.Characters.Last.InsertBefore Text:=""""
      End If
    Next aCell
    .Columns.PreferredWidthType = wdPreferredWidthPoints
    .Columns.PreferredWidth = InchesToPoints(2.7)
    .Columns(2).PreferredWidth = InchesToPoints(3.63)
    For Each oBorder In .Borders
    oBorder.LineStyle = wdLineStyleNone
    Next oBorder
    End With
  
  'Reinstate the tabs and paragraphs
  With aRng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .MatchWildcards = False
    .Text = "|"
    .Replacement.Text = "^p"
    .Execute Replace:=wdReplaceAll
    
    .Text = "zzTabzz"
    .Replacement.Text = "^t"      'or a space if you prefer
    .Execute Replace:=wdReplaceAll
  End With
  
  'Remove all local formatting
  ActiveDocument.Range.Font.Reset
  Call DPU_ApplyHeadingStylesToTableTable
  Application.ScreenUpdating = True
End Sub