Sub Applystyles()
Dim markup As Style
Dim applystyles_section, applystyles_sub1, first_section, first_sub1 As Boolean
Dim myRange As Range
Dim starting_point, lastelementprocessed As String
Application.ScreenUpdating = False
Set myRange = ActiveDocument.Range
With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(1).NumberFormat = "%1."
.NumberStyle = wdListNumberStyleArabic
.LinkedStyle = "Section"
.StartAt = 1
End With
With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(2).NumberFormat = "%2."
.NumberStyle = wdListNumberStyleLowercaseLetter
.LinkedStyle = "Sub section a"
.StartAt = 1
End With
With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(3).NumberFormat = "%3°."
.NumberStyle = wdListNumberStyleArabic
.LinkedStyle = "Subsub section 1°"
.StartAt = 1
End With
With ListGalleries(wdOutlineNumberGallery).ListTemplates(1).ListLevels(4).NumberFormat = "%4."
.NumberStyle = wdListNumberStyleLowercaseRoman
.LinkedStyle = "Subsubsub section i"
.StartAt = 1
End With
applystyles_section = True
applystyles_sub1 = True
first_section = True
first_sub1= True
starting_point = ""
lastelementprocessed= ""
If MsgBox(“First run?”, vbYesNo) = vbNo Thenstarting_point = "Article " & InputBox("Input number of starting article or leave blank if process needs to start at beginning of document")
End If
With myRangeIf starting_point = "" Then
.Start = ActiveDocument.Range.Start
.Collapse Direction:=wdCollapseStart
.Move Unit:=wdParagraph
.Expand Unit:=wdParagraph
Else
With .Find
.Text = starting_point
.Style = ActiveDocument.Styles("article_heading")
.Execute
If Not (.Found = True) Then
MsgBox ("Article not found. Macro will shutdown.")
Exit Sub
End If
End With
End If
.Select
Set markup = .Style
End With
On Error GoTo ErrHandler
Do Until (myRange.End = ActiveDocument.Range.End)Select Case markup
Case ActiveDocument.Styles("article_heading")
applystyles_section = True
applystyles_sub1 = True
first_section = True
first_sub1= True
Case ActiveDocument.Styles("section_heading")
If first_section = True And applystyles_section = True Then
myRange.ListFormat.ApplyListTemplateWithLevel ListTemplate:=ListGalleries(wdOutlineNumberGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
applystyles_section = False
first_section = False
End If
Case ActiveDocument.Styles("sub section a")
If first_sub1 = True And applystyles_sub1 = True And first_section = True Then
myRange.ListFormat.ApplyListTemplateWithLevel ListTemplate:=ListGalleries(wdOutlineNumberGallery).ListTemplates(1), ContinuePreviousList:=False, ApplyTo:=wdListApplyToWholeList, DefaultListBehavior:=wdWord10ListBehavior
applystyles_sub1 = False
first_sub1= False
End If
End Select
With myRange
.Move Unit:=wdParagraph, Count:=1
.Expand Unit:=wdParagraph
.Select
Set markup = .Style
If .Style = ActiveDocument.Styles("Article_heading") Then
lastelementprocessed= .Text
End If
End With
ActiveDocument.UndoClear
Loop
MsgBox ("The macro is done.")
Exit Sub
ErrHandler:
MsgBox ("Error: " & Err.Description)
MsgBox ("The last element that was processed correctly is: " & lastelementprocessed & ". Write this down!")
Set myRange = Nothing
Application.Quit SaveChanges:=wdPromptToSaveChanges
End Sub