Microsoft Office Forums - View Single Post - VBA find word and create numbered list under it

gmayor · 04-22-2018, 08:49 PM

The original macro worked, but not 100% reliably. The following should do the job and you can call it from your main macro before the message box at the end.

Code:

Sub NumberSection()
Dim orng As Range
    Set orng = ActiveDocument.Range
    With orng.Find
        Do While .Execute(FindText:="Assessment:")
            With orng
                .End = ActiveDocument.Range.End
                .End = .Start + InStr(orng, "Diagnosis:") - 2
                .MoveStart wdParagraph
                .ListFormat.ApplyListTemplateWithLevel _
                        ListTemplate:=ListGalleries(wdNumberGallery).ListTemplates(1)
                .ParagraphFormat.LeftIndent = CentimetersToPoints(0)
                .ParagraphFormat.FirstLineIndent = CentimetersToPoints(0)
                .ParagraphFormat.TabStops.Add _
                        Position:=CentimetersToPoints(0.5), _
                        Alignment:=wdAlignTabLeft, _
                        Leader:=wdTabLeaderSpaces
            End With
            Exit Do
        Loop
    End With
lbl_Exit:
    Set orng = Nothing
    Exit Sub
End Sub