VBA Create Bullet Style for Find/Replace Command

Question

We have documents that are downloaded with concatenated sentences using * to separate different commentators.  I need to find a way to have a macro that can be stored as part of the normal.dot and converts these * sentences to bullet points among other page/formatting changes.  I have found the find and replace function can do this if the bullet format is set as a style.

I seem to be able to create the 'Bullet' style via vba through the macro record function, but the style doesn't keep the bullets or 'list' formatting.

Does anyone know how to keep the list formatting when creating a style using vba?

Or, have other ideas for how to make this same function happen?

We need to use it on existing documents on a regular basis, so having it part of the normal.dot as a macro seemed like the way to go...

Lisa

Answer 1

Thanks Jay!!  That put me on the right path.

I had to change the optional execute find/replace lines to a single one and then I added coding that changes the list paragraph style to actual bullets with a .5 indent.

Other modifications include removing the *s and changing the document font to our standard and paragraph spacing to single.  Not sure why Word defaults to the 1.08 spacing...but that is a wish list item for a future build.  :)

See below for the revised coding - may be helpful for someone else too.  :)

Sub eRSScTESSFormat()

    'This macro turns * to bulleted paragraphs

     With ActiveDocument.Styles("List Paragraph").ParagraphFormat

        .LeftIndent = InchesToPoints(0.5)

        .RightIndent = InchesToPoints(0)

        .SpaceBefore = 0

        .SpaceBeforeAuto = False

        .SpaceAfter = 8

        .SpaceAfterAuto = False

        .LineSpacingRule = wdLineSpaceMultiple

        .LineSpacing = LinesToPoints(1.08)

        .Alignment = wdAlignParagraphLeft

        .WidowControl = True

        .KeepWithNext = False

        .KeepTogether = False

        .PageBreakBefore = False

        .NoLineNumber = False

        .Hyphenation = True

        .FirstLineIndent = InchesToPoints(-0.25)

        .OutlineLevel = wdOutlineLevelBodyText

        .CharacterUnitLeftIndent = 0

        .CharacterUnitRightIndent = 0

        .CharacterUnitFirstLineIndent = 0

        .LineUnitBefore = 0

        .LineUnitAfter = 0

        .MirrorIndents = False

        .TextboxTightWrap = wdTightNone

        .CollapsedByDefault = False

    End With

    ActiveDocument.Styles("List Paragraph"). _

        NoSpaceBetweenParagraphsOfSameStyle = True

    With ListGalleries(wdBulletGallery).ListTemplates(1).ListLevels(1)

        .NumberFormat = ChrW(61623)

        .TrailingCharacter = wdTrailingTab

        .NumberStyle = wdListNumberStyleBullet

        .NumberPosition = InchesToPoints(0.25)

        .Alignment = wdListLevelAlignLeft

        .TextPosition = InchesToPoints(0.5)

        .TabPosition = wdUndefined

        .ResetOnHigher = 0

        .StartAt = 1

        With .Font

            .Bold = wdUndefined

            .Italic = wdUndefined

            .StrikeThrough = wdUndefined

            .Subscript = wdUndefined

            .Superscript = wdUndefined

            .Shadow = wdUndefined

            .Outline = wdUndefined

            .Emboss = wdUndefined

            .Engrave = wdUndefined

            .AllCaps = wdUndefined

            .Hidden = wdUndefined

            .Underline = wdUndefined

            .Color = wdUndefined

            .Size = wdUndefined

            .Animation = wdUndefined

            .DoubleStrikeThrough = wdUndefined

            .Name = "Symbol"

        End With

        .LinkedStyle = "List Paragraph"

    End With

    ActiveDocument.Styles("List Paragraph").LinkToListTemplate ListTemplate:= _

        ListGalleries(wdBulletGallery).ListTemplates(1), ListLevelNumber:=1

    With ActiveDocument.Styles("List Paragraph")

        .AutomaticallyUpdate = False

        .BaseStyle = "Normal"

        .NextParagraphStyle = "List Paragraph"

    End With

   Dim rg As Range

   ActiveDocument.Range.Find.Execute FindText:="*", Replacewith:="^p*", Replace:=wdReplaceAll

   ' turn off all AutoFormat options except bullets

   With Options

     .AutoFormatApplyBulletedLists = True

     .AutoFormatApplyFirstIndents = True

     .AutoFormatApplyHeadings = False

     .AutoFormatApplyLists = False

     .AutoFormatApplyOtherParas = False

   End With

   Set rg = ActiveDocument.Range

   With rg.Find

     .Text = "*"

     While .Execute

       If rg.Start = rg.Paragraphs(1).Range.Start Then

         ' star is first character in current paragraph

         rg.Style = ActiveDocument.Styles("List Paragraph")

         rg.Paragraphs(1).Range.AutoFormat

       End If

       ' prepare to search for next star

       rg.Collapse wdCollapseEnd

     Wend

   End With

   ' restore default settings

   With Options

     .AutoFormatApplyFirstIndents = True

     .AutoFormatApplyHeadings = True

     .AutoFormatApplyLists = True

     .AutoFormatApplyOtherParas = True

   End With

   Selection.WholeStory

    Selection.Font.Name = "Arial"

    Selection.Font.Size = 11

    With Selection.ParagraphFormat

        .SpaceBefore = 0

        .SpaceBeforeAuto = False

        .SpaceAfter = 0

        .SpaceAfterAuto = False

        .LineSpacingRule = wdLineSpaceSingle

        .LineUnitBefore = 0

        .LineUnitAfter = 0

    End With

     ActiveDocument.Range.Find.Execute FindText:="*", Replacewith:="", Replace:=wdReplaceAll

 End Sub

Thanks again,

Lisa

Answer 2

Word has a built-in command called AutoFormat (similar to but distinct from "AutoFormat As You Type") that can be restricted to applying bullets to the starred sentences.

Manually, you could go to File > Options > Proofing > AutoCorrect Options > AutoFormat and uncheck all the boxes except "Automatic bulleted lists", and then execute the AutoFormat Now command (which is not on the ribbon but can be added to the Quick Access Toolbar).

In VBA, it would look something like this -- a first pass that will probably need some tweaks to meet your formatting needs.

Sub AutoFormatBullets()

  Dim rg As Range

  ' turn off all AutoFormat options except bullets

  With Options

    .AutoFormatApplyBulletedLists = True

    .AutoFormatApplyFirstIndents = False

    .AutoFormatApplyHeadings = False

    .AutoFormatApplyLists = False

    .AutoFormatApplyOtherParas = False

  End With

  ' if there are multiple starred sentences in the same paragraph,

  ' uncomment the following three lines to break them apart

'  With ActiveDocument.Range

'    .Find.Execute findtext:="* ", Replacewith:="^p* ", Replace:=wdReplaceAll

'  End With

  Set rg = ActiveDocument.Range

  With rg.Find

    .Text = "*"

    While .Execute

      If rg.Start = rg.Paragraphs(1).Range.Start Then

        ' star is first character in current paragraph

        rg.Style = ActiveDocument.Styles("List Paragraph")

        rg.Paragraphs(1).Range.AutoFormat

      End If

      ' prepare to search for next star

      rg.Collapse wdCollapseEnd

    Wend

  End With

  ' restore default settings

  With Options

    .AutoFormatApplyFirstIndents = True

    .AutoFormatApplyHeadings = True

    .AutoFormatApplyLists = True

    .AutoFormatApplyOtherParas = True

  End With

End Sub