I've now managed to (I think) tackle the single word spacing and remove empty paragraphs at the start and end.
Only bit now is when pressing the "Edit Document" ribbon button, all the text bunches together on the UserForm and doesn't maintain the paragraph spacing. Click "Enter" again and the paragraphs show correctly on the document.
When copying the finished text from the document and pasting into our bespoke system that accepts RTF format, the paragraphs disappear as per that in the UserForm like this:-
Chancellor Alexander Schallenberg said it would last a maximum of 20 days and there would be a legal requirement to get vaccinated from 1 February 2022.
He was responding to record case numbers and one of the lowest vaccination levels in Western Europe.
Many other European countries are imposing restrictions as cases rise.
"We don't want a fifth wave," said Mr Schallenberg after meeting the governors of Austria's nine provinces at a resort in the west of the country.
For a long time, there had been a consensus over avoiding mandatory vaccinations, the chancellor said.
However, too many people had been incited not to get the jab, because of "too many political forces, flimsy vaccination opponents and fake news", he added. The measures are yet to be finalised.
Option Explicit
Sub CreateDoc()
Dim oDoc As Document
Dim oRng As Range
Dim oRngPara As Range
Dim oCC As ContentControl
Dim oFrmPPN1 As frmPPN1
If ActiveDocument = ThisDocument Then
MsgBox "You cannot use this function to edit the document template", vbCritical
Exit Sub
End If
Set oDoc = ActiveDocument
Set oFrmPPN1 = New frmPPN1
With oFrmPPN1
For Each oCC In oDoc.ContentControls
If oCC.ShowingPlaceholderText = False Then
Select Case oCC.Title
Case "PPN1"
.txtPPN1.Text = oCC.Range.Text
End Select
End If
Next oCC
.Show
If .Tag = 0 Then GoTo lbl_Exit
For Each oCC In oDoc.ContentControls
'Set a range to the content control
Set oRng = oCC.Range
Select Case oCC.Title
Case "PPN1"
'Fill the range with the content of the text box
oRng.Text = .txtPPN1.Text
Application.ScreenUpdating = False
' Ensure there is only single spacing between words
With oRng.Find
.ClearFormatting
.Replacement.ClearFormatting
'Here is where it is actually looking for spaces between words
.Text = " [ ]@([! ])"
'This line tells it to replace the excessive spaces with one space
.Replacement.Text = " \1"
.MatchWildcards = True
.Wrap = wdFindStop
.Format = False
.Forward = True
.Execute Replace:=wdReplaceAll
End With
' Ensure there is only single line spacing between paragraphs
With oRng.Find
.MatchWildcards = True
.Text = "[^13]{2,}"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
.Text = "[^l]{2,}"
.Replacement.Text = "^l"
.Execute Replace:=wdReplaceAll
.Text = "[^13^l]{2,}"
.Replacement.Text = "^p"
.Execute Replace:=wdReplaceAll
End With
'Convert to sentence case
oRng.Case = wdTitleSentence
' Ensure any first or last empty paragraphs are removed
Set oRngPara = ActiveDocument.Paragraphs(1).Range
If oRngPara.Text = vbCr Then oRngPara.Delete
Set oRngPara = ActiveDocument.Paragraphs.Last.Range
If oRngPara.Text = vbCr Then oRngPara.Delete
Application.ScreenUpdating = True
End Select
Next oCC
End With
lbl_Exit:
Unload oFrmPPN1
Set oFrmPPN1 = Nothing
Set oRng = Nothing
Set oRngPara = Nothing
Set oCC = Nothing
Set oDoc = Nothing
Exit Sub
End Sub