Search code examples
vbams-wordstyles

Changing styles in Word

I am very new to programming, so forgive my ignorance.

I am trying to create specific headings in a document that does not have any or has different heading styles assigned. What precedes the text in the headings are numbers. The numbers are specific and essentially represent the content of the material below the heading and thus are not going to change. I am looking for a way to run a macro that would reformat the numeric headings along with the text beside it. This will aid in navigating through the document. When I typed in the code, I got no errors, but the Headings are formatted with the "Heading 2" style only, even though multiple heading styles are used. Any help in this area would be appreciated very much. The code is listed below:

Sub QOS_Headings()_

'
' QOS_Headings Macro

' Converts section headings in eCTD to usable navigation headings in Word.

'
Selection.Find.Text = ("3.2")_

Selection.Style = ActiveDocument.Styles("Heading 1")
Selection.Find.Text = ("3.2.S")
Selection.Style = ActiveDocument.Styles("Heading 2")
Selection.Find.Text = ("3.2.S.1")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.S.2")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.S.3")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.S.4")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.S.4.1")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.S.4.2")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.S.4.3")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.S.4.4")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.S.4.5")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.S.6")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.S.7")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.P")
Selection.Style = ActiveDocument.Styles("Heading 2")
Selection.Find.Text = ("3.2.P.1")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.P.2")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.P.3")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.P.4")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.P.5")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.P.5.1")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.P.5.2")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.P.5.3")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.P.5.4")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.P.5.5")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.P.5.6")
Selection.Style = ActiveDocument.Styles("Heading 4")
Selection.Find.Text = ("3.2.P.6")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.P.7")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.P.8")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.A")
Selection.Style = ActiveDocument.Styles("Heading 2")
Selection.Find.Text = ("3.2.A.1")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.A.2")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.A.3")
Selection.Style = ActiveDocument.Styles("Heading 3")
Selection.Find.Text = ("3.2.R")
Selection.Style = ActiveDocument.Styles("Heading 2")
End Sub
Solution

  • So, there are a few ways to make your code more expandable or reusable. You could use wildcard searches to minimize the actual number of searches required. Or you could put your text strings into an array that you loop through to keep the actual code to a minimum. For your purposes, and to make this as clear as possible, I haven't done that. This just takes your searches and makes them actual search and replaces so that changes are only made when the text is found. In order to limit your searches to text on its own line, I've added the special "^p" find sequence. This searches for your text followed by a paragraph break. That's not perfect, but it should be closer to what you're looking for. If you're still seeing only Heading 2 applied after you run this, it might be necessary to include a portion of the text of your document in your question to clarify exactly what it looks like.

    Sub QOS_Headings()
Dim objDoc As Document
Dim head1 As Style, head2 As Style, head3 As Style, head4 As Style
'
' QOS_Headings Macro

' Converts section headings in eCTD to usable navigation headings in Word.

'

' Using variables here just simplifies the typing further on, and allows
' you to easily change, for instance, "Heading 4" to "My Personal Heading 4"
' if you were creating your own styles.

Set objDoc = ActiveDocument
' This code does *NOT* protect against the possibility that these styles don't
' appear in the document. That's probably not a concern with built-in styles,
' but be aware of that if you want to expand upon this for other uses.
Set head1 = ActiveDocument.Styles("Heading 1")
Set head2 = ActiveDocument.Styles("Heading 2")
Set head3 = ActiveDocument.Styles("Heading 3")
Set head4 = ActiveDocument.Styles("Heading 4")

' This searches the entire document (not including foot/endnotes, headers, or footers)
' for your text string. Putting "^p" at the end of the string limits it to text strings
' that fall at the end of a paragraph, which is likely the case as your headings sit on
' their own line. You might want to experiment with that. Note that putting ^p at the
' beginning of the text will NOT work; that will apply your style to the previous
' paragraph as well.
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2^p"
    With .Replacement
    .ClearFormatting
    .Style = head1
    End With
    ' Here we do the actual replacement. Based on your requirements, this only replaces the
    ' first instance it finds. You could also change this to Replace:=wdReplaceAll to catch
    ' all of them.
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With

With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S^p"
    With .Replacement
    .ClearFormatting
    .Style = head2
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.1^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.2^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.3^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.4^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.4.1^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.4.2^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.4.3^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.4.4^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.4.5^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.6^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.S.7^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P^p"
    With .Replacement
    .ClearFormatting
    .Style = head2
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.1^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.2^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.3^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.4^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.5^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.5.1^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.5.2^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.5.3^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.5.4^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.5.5^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.5.6^p"
    With .Replacement
    .ClearFormatting
    .Style = head4
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.6^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.7^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.P.8^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.A^p"
    With .Replacement
    .ClearFormatting
    .Style = head2
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.A.1^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.A.2^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.A.3^p"
    With .Replacement
    .ClearFormatting
    .Style = head3
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
With objDoc.Content.Find
    .ClearFormatting
    .Text = "3.2.R^p"
    With .Replacement
    .ClearFormatting
    .Style = head2
    End With
    .Execute Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceOne
End With
End Sub

    One final suggestion: one way to get started with VBA programming is to use the macro recorder. It's not perfect, but it will give you the basic structure of, for instance, a search and replace if you record yourself doing one.