Hi, many thanks for replying it is very much appreciated. Background is I house style documents, converted from pdf to word mostly, I copy the definitions part into a blank document then run the macro. Once I've checked for errors I run another macro that converts text to correct styles and inserts 2 column table, hence the tabs before non-bold sentences. I have attached a copy of the table document also. There is an issue where the definition starts with a), b) and not (a), (b). House style is Arial 10, 0pt before, 9pt after, line spacing At Least 15. I've tried to comment as much as possible in the BEFORE MACRO IS RUN document. Thank you for looking at this.
BEFORE MACRO IS RUN definitions test 1.docx
AFTER MACRO IS RUN definitions test 2.docx
CONVERTED TO TABLE FORMAT definitions test 3.docx
Code:
Sub DPU_Definitions()
Dim orng As Range
Dim Para As Paragraph
Application.ScreenUpdating = False
'Create placeholder.
ActiveDocument.Range.InsertBefore vbCr
ActiveDocument.Paragraphs(1).Range.Font.Bold = False
'Convert numbers to text'
ActiveDocument.Range.ListFormat.ConvertNumbersToText
Set orng = ActiveDocument.Range
ResetFRParameters
With orng.Find
'Remove colons'
.Text = ":"
.Font.Bold = True
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'Remove colons and add double quotes'
.Text = ":"""
.Replacement.Text = """"
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'remove bold from spaces after athe word means
.Text = "means "
.Replacement.Text = "means "
.Replacement.Font.Bold = True
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'Delete white spaces before paragraph breaks
.Text = "^w^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'Delete white spaces after paragraph breaks
.Text = "^p^w"
.Execute Replace:=wdReplaceAll
End With
Set orng = ActiveDocument.Range
With orng.Find
'Remove bold formatting from punctuation and para marks
.Text = "[" & Chr(13) & ".;,:]"
.MatchWildcards = True
.Font.Bold = True
.Replacement.Font.Bold = False
.Execute Replace:=wdReplaceAll
End With
'Clear space before tabs
With orng.Find
.Text = " ^t"
.Replacement.Text = "^t"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'Remove double quotes
.Text = """"
.Replacement.Text = ""
.Execute Replace:=wdReplaceAll
End With
Set orng = ActiveDocument.Range
'Replace tab with space
With orng.Find
.Text = "^t"
.Replacement.Text = " "
.Execute Replace:=wdReplaceAll
End With
Set orng = ActiveDocument.Range
'Insert Bold quotes for bold definition text at beginning of sentence
With orng.Find
.Text = ""
.Replacement.Text = "^034^&^034"
.Font.Bold = True
.Format = True
.MatchWildcards = True
While .Execute
If Not InStr(orng.Text, Chr(13)) Then
While orng.Characters.Last = Chr(32)
orng.Characters.Last.Font.Bold = False
orng.End = orng.End - 1
Wend
orng.Text = Chr(34) & orng.Text & Chr(34)
If orng.Characters.First.Previous = Chr(13) Then
orng.Collapse wdCollapseEnd
orng.Font.Bold = False
orng.Characters.Last = vbTab
Else
orng.Collapse wdCollapseEnd
End If
End If
Wend
End With
ResetFRParameters
Set orng = ActiveDocument.Range
'insert tab at beginning of paragraph with a bracket e.g. (a), (i), (1)
With orng.Find
.MatchWildcards = True
.Text = "^13(\([a-z0-9]{1,}\))"
.Replacement.Text = "^p^t\1"
.Execute Replace:=wdReplaceAll
End With
'insert tab at beginning of paragraph e.g a), 1), i), 100 etc.
With orng.Find
.MatchWildcards = True
.Text = "^13([a-z0-9\)]{1,})"
.Replacement.Text = "^p^t\1"
.Execute Replace:=wdReplaceAll
End With
'Remove the words means from each definition and insert a tab'
Set orng = ActiveDocument.Range
With orng.Find
.Text = "^tmeans"
.Replacement.Text = "^t"
.Execute Replace:=wdReplaceAll
End With
'Remove the words means and space before and insert a tab'
Set orng = ActiveDocument.Range
With orng.Find
.Text = " ^tmeans"
.Replacement.Text = "^t"
.Execute Replace:=wdReplaceAll
End With
Set orng = ActiveDocument.Range
'Clears colons or commas after tabs.
With orng.Find
.Text = "[^t]([:\,]){1,}"
.Replacement.Text = "^t"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
'Clear space after tabs
With orng.Find
.Text = "^t "
.Replacement.Text = "^t"
.MatchWildcards = True
.Execute Replace:=wdReplaceAll
End With
With orng.Find
'Remove colons
.Text = ":"""
.Replacement.Text = """"
.Execute Replace:=wdReplaceAll
End With
'Highligt tabs so user can check for errors when code has run
Set orng = ActiveDocument.Range
Options.DefaultHighlightColorIndex = wdYellow
With orng.Find
.Text = "^t"
.Replacement.Text = "^t"
.Replacement.Highlight = True
.Execute Replace:=wdReplaceAll
End With
ResetFRParameters
Set orng = ActiveDocument.Range
With orng.Find
.Text = "^t"
Do While .Execute
orng.Start = orng.Paragraphs(1).Range.Start
If Len(.Text) - Len(Replace(.Text, vbTab, "")) > 1 Then orng.Characters.Last.Text = " "
orng.Collapse wdCollapseEnd
Loop
End With
'Remove period from end of sentence
Set orng = ActiveDocument.Range
With orng.Find
.Text = ".^p"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
'Remove period before square bracket at end of sentence
Set orng = ActiveDocument.Range
With orng.Find
.Text = ".]^p"
.Replacement.Text = "]^p"
.Execute Replace:=wdReplaceAll
End With
'Insert semi-colon at end of sentences but not for and, but, or, then
Set orng = ActiveDocument.Range
For Each Para In ActiveDocument.Paragraphs
With Para.Range
If Len(.Text) > 2 Then
If Not .Characters.Last.Previous Like "[.!?:;]" Then
Select Case .Words.Last.Previous.Words(1)
Case "and", "but", "or", "then"
'do nothing
Case Else
.Characters.Last.InsertBefore ";"
End Select
End If
End If
End With
Next
'Remove placeholder.
ActiveDocument.Paragraphs(1).Range.Delete
Set orng = ActiveDocument.Range
With orng.Find
.Text = "^13[A-Za-z]"
.MatchWildcards = True
Do While .Execute
If orng.Paragraphs(2).Style = "Normal" And _
orng.Paragraphs(2).Range.Characters(1).Font.Bold = False Then
orng.Paragraphs(2).Range.InsertBefore vbTab
End If
orng.Collapse 0
Loop
End With
Application.ScreenUpdating = True
lbl_Exit:
Set orng = Nothing
Exit Sub
End Sub
Code:
Sub ResetFRParameters()
With Selection.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = ""
.Replacement.Text = ""
.Forward = True
.Wrap = wdFindStop
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
.Execute
End With
lbl_Exit:
Exit Sub
End Sub
Code:
Sub DPU_TextToTables()
Dim oBorder As Border
Dim Para As Paragraph
Selection.WholeStory
Selection.ConvertToTable Separator:=wdSeparateByTabs, NumColumns:=2, _
NumRows:=8, AutoFitBehavior:=wdAutoFitFixed
With Selection.Tables(1)
.Style = "Table Grid"
.ApplyStyleHeadingRows = True
.ApplyStyleLastRow = False
.ApplyStyleFirstColumn = True
.ApplyStyleLastColumn = False
With .Range
.Font.Name = "Arial"
.Font.Size = 10
With .ParagraphFormat
.SpaceBefore = 0
.SpaceBeforeAuto = False
.SpaceAfter = 9
.SpaceAfterAuto = False
.LineSpacingRule = wdLineSpaceAtLeast
.LineSpacing = 15
.LineUnitBefore = 0
.LineUnitAfter = 0
End With
End With
With .Columns(1)
.PreferredWidth = InchesToPoints(2.7)
.Select
With Selection.ParagraphFormat
.Alignment = wdAlignParagraphLeft
.LeftIndent = InchesToPoints(1)
.Style = "DefBold"
End With
For Each oBorder In .Borders
oBorder.LineStyle = wdLineStyleNone
Next oBorder
End With
With .Columns(2)
.Select
With Selection.ParagraphFormat
.Alignment = wdAlignParagraphJustify
End With
.PreferredWidth = InchesToPoints(3.63)
For Each oBorder In .Borders
oBorder.LineStyle = wdLineStyleNone
Next oBorder
End With
Call DPU_ApplyHeadingStylesToTableTable
End With
End Sub