Word Macro – Short Lines

I created this VBA macro so that I could insert paragraph returns at suitable places in a doc in order that each line was no more than 80 characters (so that when I send it to bloomberg it formats properly).

Sub ShortLines()
‘
‘ Author rrheaume
‘
LineLength = 80 ‘change as required
BiggestWord = 25 ‘change as required

Limit = ActiveDocument.Characters.Count * 1.2 ‘ just incase something goes wrong!

Selection.HomeKey Unit:=wdStory

‘ clean the text up a bit and ID tabs which will be replaced with 4 spaces (ggg)

With Selection.Find
.Text = “^p”
.Replacement.Text = “^p^p”
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

With Selection.Find
.Text = “^p^t”
.Replacement.Text = “^pgggg ”
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.MatchSoundsLike = False
.MatchAllWordForms = False
End With
Selection.Find.Execute Replace:=wdReplaceAll

With Selection.Find
.Text = “^t”
.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

For Loops = 1 To ActiveDocument.Characters.Count / 40

‘ reset counters

RightMover = 0
SkipOver = 0
LeftMover = 0

‘ Move right until you get to a paragraph return or a count of 80
‘ If you get to a paragraph return skip over the next step and start over

For x = 1 To LineLength
If RightMover < LineLength Then Selection.MoveRight Unit:=wdCharacter, Count:=1 RightMover = RightMover + 1 BigCounter = BigCounter + 1 If BigCounter > Limit Then Exit Sub
If Selection.Text = Chr(13) Then
SkipOver = 1
RightMover = LineLength + 1
End If
End If
Next x

‘ move left until you find a space character then insert a paragraph mark

If SkipOver = 0 Then
For Y = 1 To BiggestWord
If LeftMover < BiggestWord + 1 Then Selection.MoveRight Unit:=wdCharacter, Count:=-1 If Selection.Text = Chr(13) Then LeftMover = BiggestWord + 1 If Selection.Text = " " Then Selection.TypeParagraph LeftMover = BiggestWord + 1 End If LeftMover = LeftMover + 1 End If Next Y End If Next Loops ' the rest just cleans up the text a bit With Selection.Find .Text = "^p " .Replacement.Text = "^p" .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.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll With Selection.Find .Text = " ^p" .Replacement.Text = "^p" .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.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll For Y = 1 To 10 With Selection.Find .Text = "^p^p^p" .Replacement.Text = "^p^p" .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.Execute Replace:=wdReplaceAll Next Y Selection.WholeStory With Selection.ParagraphFormat .SpaceBefore = 0 .SpaceBeforeAuto = False .SpaceAfter = 0 .SpaceAfterAuto = False .LineUnitBefore = 0 .LineUnitAfter = 0 End With Selection.HomeKey Unit:=wdStory ' then we go back in an find the tab marker (gggg) and replace it with spaces With Selection.Find .Text = "^pgggg" .Replacement.Text = "^p " .Forward = True .Wrap = wdFindContinue .Format = False .MatchCase = False .MatchWholeWord = False .MatchWildcards = False .MatchSoundsLike = False .MatchAllWordForms = False End With Selection.Find.Execute Replace:=wdReplaceAll 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 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.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll Selection.Find.Execute Replace:=wdReplaceAll End Sub