Changing styles in Word

2
votes

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
1
vbams-wordstyles
Are you certain that all of these text strings actually exist in your document? You're not checking whether or not they were found before you apply a style. – Christina
Hi Christina. Thanks for your reply. If you mean that those 3.2* numbers exist int he doc, then yes they do. As I said, I am very new to this programming thing. ;). Essentially, I am trying to pick out the numbers that are always in these docs, and then formatting them to a tiered heading style, leaving the text within the sections alone. Do I have to tell the program to select the whole document to search? Any info you could provide would be helpful. – DP7
Does each number only appear once, and do they appear on their own lines? – Christina
Yes, each number would appear only once and on their own lines. However, there may be numbers in the body of the document that may appear as 3.2 on their own. To get around that issue, I could add the verbal title to the associated section. For example, "3.2 Method". Those titles would also not change from document to document. The content under each Heading could be radically different and vary in length. – DP7

1 Answers

4
votes

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.