I'm trying to tidy up all paragraphs for a number of Content Controls within the same document. The idea is to remove any blank paragraphs at the start and end of each whilst ensuring single paragraph spacing in between each paragraph. This should also tidy up and ensure single word spacing.
So far I have the following which is working with the exception of not removing empty paragraphs at the start. No matter what I try I just cannot get them removed, there is always a double return.
Content.jpg
As this is going to be used a number of times, I will place in its own sub and call as required after setting the range.
Option Explicit Sub CreateDoc() Dim oDoc As Document Dim oRng As Range Dim oRngPara As Range Dim oParagraphCount As Long Dim x As Integer Dim intCounter As Integer Dim oCtrl As control Dim oCC As ContentControl Dim oFrmTriageRC As frmTriageRC If ActiveDocument = ThisDocument Then MsgBox "You cannot use this function to edit the document template", vbCritical Exit Sub End If Set oDoc = ActiveDocument Set oFrmTriageRC = New frmTriageRC With oFrmTriageRC For Each oCC In oDoc.ContentControls If oCC.ShowingPlaceholderText = False Then Select Case oCC.Title Case "Summary" .txtSummary.Text = oCC.Range.Text Case "Research" .txtResearch.Text = oCC.Range.Text End Select End If Next oCC .Show If .Tag = 0 Then GoTo lbl_Exit For Each oCC In oDoc.ContentControls On Error Resume Next Select Case oCC.Title Case "Summary" oRng.Text = .txtSummary.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 On Error Resume Next ' Ensure there is only single paragraph spacing oParagraphCount = oDoc.Paragraphs.Count 'Loop Through Each Paragraph (in reverse order) For x = oParagraphCount To 1 Step -1 If x - 1 > 1 Then If oRng.Paragraphs(x).Range.Text = vbCr And oRng.Paragraphs(x - 1).Range.Text = vbCr Then oRng.Paragraphs(x).Range.Delete End If End If Next x ' Ensure empty first paragraphs are removed intCounter = 1 Do Set oRngPara = oRng.Paragraphs(1).Range If oRngPara.Text = vbCr Then oRngPara.Delete intCounter = intCounter + 1 Loop Until intCounter >= 5 ' Ensure empty last paragraphs are removed intCounter = 1 Do Set oRngPara = oRng.Paragraphs.Last.Range If oRngPara.Text = vbCr Then oRngPara.Delete intCounter = intCounter + 1 Loop Until intCounter >= 5 ' Convert to sentence case oRng.Case = wdTitleSentence Application.ScreenUpdating = True Case "Research" oRng.Text = .txtResearch.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 On Error Resume Next ' Ensure there is only single paragraph spacing oParagraphCount = oDoc.Paragraphs.Count 'Loop Through Each Paragraph (in reverse order) For x = oParagraphCount To 1 Step -1 If x - 1 > 1 Then If oRng.Paragraphs(x).Range.Text = vbCr And oRng.Paragraphs(x - 1).Range.Text = vbCr Then oRng.Paragraphs(x).Range.Delete End If End If Next x ' Ensure empty first paragraphs are removed intCounter = 1 Do Set oRngPara = oRng.Paragraphs(1).Range If oRngPara.Text = vbCr Then oRngPara.Delete intCounter = intCounter + 1 Loop Until intCounter >= 5 ' Ensure empty last paragraphs are removed intCounter = 1 Do Set oRngPara = oRng.Paragraphs.Last.Range If oRngPara.Text = vbCr Then oRngPara.Delete intCounter = intCounter + 1 Loop Until intCounter >= 5 ' Convert to sentence case oRng.Case = wdTitleSentence End Select Next oCC End With lbl_Exit: Unload oFrmTriageRC Set oFrmTriageRC = Nothing Set oRng = Nothing Set oCC = Nothing Set oDoc = Nothing Exit Sub End Sub