Count number of periods and convert paragraph to a heading style

jeffreybrown · #1 10-16-2019, 04:20 PM

I found this code which works good to count the number of periods in the numbering and then convert to the appropriate heading style. The numbering is currently not automated.

1.1. dkfsdflk j
1.2. dkfsdflk j
1.2.1. dkfsdflk j

So in the above example, the first two paragraphs will be heading 2 and then the last heading 3. I'm going to have to expand this out to at least heading 6, so instead of writing out the patterns six times, how can we just count the number of periods and apply the style based off of that number?

Code:

Sub Converttoheadingstyle()
   
    Dim oPara   As Paragraph
    Dim wdDoc   As Range
    Dim rgTemp  As Range
    
    If Selection.Type = wdSelectionNormal Then: Set wdDoc = Selection.Range: Else: Set wdDoc = ActiveDocument.Range
   
    For Each oPara In wdDoc.Paragraphs: Set rgTemp = oPara.Range.Duplicate
        
        If rgTemp.Find.Execute(FindText:="[0-9]{1,}.[0-9]{1,}.[0-9]{1,}. ", MatchWildcards:=True) Then
          oPara.Style = ActiveDocument.Styles("Heading 3"): rgTemp.Text = ""
        
        ElseIf rgTemp.Find.Execute(FindText:="[0-9]{1,}.[0-9]{1,}.  ", MatchWildcards:=True) Then
          oPara.Style = ActiveDocument.Styles("Heading 2"): rgTemp.Text = ""
        
        ElseIf rgTemp.Find.Execute(FindText:="[0-9]{1,}.  ", MatchWildcards:=True) Then
          oPara.Style = ActiveDocument.Styles("Heading 1"): rgTemp.Text = ""
        End If
        
      Next oPara
     
End Sub

gmaxey · #2 10-17-2019, 08:17 AM

Code:

Sub Converttoheadingstyle()
Dim oPara As Paragraph
Dim oRng As Range
Dim oParRng As Range
Dim lngCount As Long

  If Selection.Type = wdSelectionNormal Then: Set oRng = Selection.Range: Else: Set oRng = ActiveDocument.Range
  For Each oPara In oRng.Paragraphs
    lngCount = 0
    Set oParRng = oPara.Range.Duplicate
    If IsNumeric(oParRng.Characters(1)) Then
      oParRng.Collapse wdCollapseStart
      Do
        oParRng.Move wdCharacter, 1
        If oParRng.Characters.Last = "." Then lngCount = lngCount + 1
        If Not IsNumeric(oParRng.Characters.Last) And oParRng.Characters.Last <> "." Then Exit Do
      Loop
      oPara.Style = ActiveDocument.Styles("Heading " & lngCount): oParRng.Text = ""
    End If
  Next oPara
lbl_Exit:
  Exit Sub
End Sub

jeffreybrown · #3 10-17-2019, 12:52 PM

Hi Greg,

This works great to convert the paragraph into a heading style based on the periods; however, the old number is left behind.

Example (after macro)
1.1. 1.1. dkfsdflk j
1.2. 1.2. dkfsdflk j
1.2.1. 1.2.1. dkfsdflk j

This first auto numbers are from the heading style and the second set of numbers is the old manually numbering.

gmaxey · #4 10-17-2019, 01:09 PM

Code:

Sub Converttoheadingstyle()
Dim oPara As Paragraph
Dim oRng As Range
Dim oParRng As Range
Dim lngCount As Long

  If Selection.Type = wdSelectionNormal Then: Set oRng = Selection.Range: Else: Set oRng = ActiveDocument.Range
  For Each oPara In oRng.Paragraphs
    lngCount = 0
    Set oParRng = oPara.Range.Duplicate
    If IsNumeric(oParRng.Characters(1)) Then
      oParRng.Collapse wdCollapseStart
      Do
        oParRng.MoveEnd wdCharacter, 1
        If oParRng.Characters.Last = "." Then lngCount = lngCount + 1
        oParRng.Select
        If Not IsNumeric(oParRng.Characters.Last) And oParRng.Characters.Last <> "." Then Exit Do
      Loop
      oPara.Style = ActiveDocument.Styles("Heading " & lngCount)
      oParRng.End = oParRng.End - 1
      oParRng.Text = ""
    End If
  Next oPara
lbl_Exit:
  Exit Sub
End Sub

jeffreybrown · #5 10-18-2019, 08:21 AM

Thanks Greg.

jeffreybrown · #6 10-19-2019, 01:03 PM

Hi Greg,

I spoke too soon. It works fine by removing the duplicate numbering, but because I use two spaces following the numbers in the multilevel list setup, I am now left with four spaces.

I used this to remove the spaces, but it doesn't work for all.

Code:

Sub DeleteSpaces()
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^13[ ]{1,}"
        .Replacement.Text = "^p"
        .Execute Replace:=wdReplaceAll
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

It removed the spaces from all the paragraphs except for heading 1.

gmaxey · #7 10-19-2019, 01:11 PM

In the code I sent, I think you can nix the oParRng.Select line (was for test).

You should be able to tinker with this line:
oParRng.End = oParRng.End - 1

Perhaps oParRng.End = oParRng.End + 1 'or maybe 2 to get it to work.

jeffreybrown · #8 10-19-2019, 01:15 PM

That did it Greg, thanks! I removed oParRng.Select and changed to +1.

Again, thanks.

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Can I create a page number from a non-Heading style?	techwriter3k	Word	9	09-25-2019 06:58 AM
Phone Number Replace ( ) and - with periods (I'm ALMOST there)	trikky	Mail Merge	4	07-19-2019 04:03 PM
applying heading style within paragraph using macro	cheech1981	Word	8	08-23-2017 03:07 PM
Heading style is not showing paragraph "before spacing" on second page	Dave_K	Word	1	07-02-2014 12:06 AM
Using heading style level in a paragraph	kam	Word	7	03-24-2014 02:58 PM