VBA Format manual numbering so auto numbering code can run

Shelley Lou · #1 08-05-2024, 02:37 AM

When documents are converted from pdf to Word to be put into housestyle, the manual numbering can often be an issue. I am trying to put together a macro that will format the manual numbering to be 1. / 1.1 / 1.1.1 / 1.1.1.1 so that I can run my auto numbering macro without it running into errors.

For the first level manual numbering, the code needs to add a period if there isn't one already there (eg from 1 to be 1. otherwise the auto numbering macro won't work.

For the second, third and fourth level numbering (e.g. 1.1 or 1.1.1 or 1.1.1.1) I need the code to remove periods at the end of the manual numbering if they are present and that the periods between the manual numbering are in fact periods and not spaces, tabs, commas, semi-colons, colons etc.

I'm running into errors with my code below - can anyone help me fine tune the code. Thanks

format manual numbering before running auto numbering code.docx

Code:

Sub FormatManualNumbering()
Application.ScreenUpdating = False
   With ActiveDocument
  With .Range
    With .Find
  .ClearFormatting
  .Forward = True
  .Wrap = wdFindContinue
  .Format = True
  .MatchWildcards = True
  .Replacement.ClearFormatting
  .text = "(^13)([0-9]@{1,})([ ^t])" 'insert period at end of manual numbering level 1 if there isn't one already there
  .Replacement.text = "\1\2.\3"
  .Execute Replace:=wdReplaceAll
    End With
    With .Find
    .ClearFormatting
  .Forward = True
  .Wrap = wdFindStop
  .Format = True
  .MatchWildcards = True
  .Replacement.ClearFormatting
  .text = "(^13)([0-9]@{1,}([.\,\:\;\ ])[0-9]{1,})([.])([ ^t])" 'insert period for manual numbering level 1.1 and remove period at end
  .Replacement.text = "\1\2.\"
  .Execute Replace:=wdReplaceAll
  .text = "(^13)([0-9]@{1,}([.\,\:\;\ ])[0-9]{1,}([.\,\:\;\ ])[0-9]{1,})([.])([ ^t])" 'insert period for manual numbering level 1.1.1 and remove period at end
  .Replacement.text = "\1\2.\3.\4"
  .Execute Replace:=wdReplaceAll
  .text = "(^13)([0-9]@{1,}([.\,\:\;\ ])[0-9]{1,}([.\,\:\;\ ])[0-9]{1,}([.\,\:\;\ ])[0-9]{1,})([.])([ ^t])" 'insert period for manual numbering level 1.1.1.1 and remove period at end
  .Replacement.text = "\1\2.\3.\4"
  .Execute Replace:=wdReplaceAll
  End With
     Application.ScreenUpdating = True
     End With
     End With
End Sub

vivka · #2 08-05-2024, 08:01 AM

Hi, Shelley Lou!
I would use a different approach:

Code:

Sub FormatManualNumbering()

Dim rng As range
Dim rngEnd As Long

Application.ScreenUpdating = False
    Set rng = ActiveDocument.range
    rngEnd = rng.End
    rng.Characters.First.InsertBefore Chr(13)
    Do
        With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchWildcards = True
            .text = "^13*^t"
            If .Execute And rng.End <= rngEnd Then
                .text = "[,:; ]"
                .Replacement.text = "."
                .Execute Replace:=wdReplaceAll
            Else: Exit Do
            End If
            If rng.Characters.Last.Previous <> "." Then
                rng.Characters.Last.InsertBefore "."
            End If
            rng.Collapse wdCollapseEnd
        End With
    Loop
ActiveDocument.range.Characters.First.Delete
Application.ScreenUpdating = True
Set rng = Nothing
End Sub

Shelley Lou · #3 08-05-2024, 11:05 PM

Hi Vivka, thank you so much for responding, that is definitely a better way - I've run the code on my test document. The code works for the most part but it needs to remove the very last period at the end of manual numbering levels 2 to 4 e.g. level 1 remains as 1. with a period but level 2-4 should be 1.1 / 1.1.1 / 1.1.1.1 and not 1.1. / 1.1.1. / 1.1.1.1. without the period at the very end. What can I add to the code to remove the very last period?

Before code has run
Before code is run.JPG

What it should look like
After code has run.JPG

vivka · #4 08-06-2024, 02:43 AM

Hi, Shelley Lou!
Sorry for not being attentive! The following code, although may be not very elegant, seems to work:

Code:

Sub FormatManualNumbering()

Dim rng As range
Dim rngEnd As Long

Application.ScreenUpdating = False
    Set rng = ActiveDocument.range
    rngEnd = rng.End
    rng.Characters.First.InsertBefore Chr(13)
    Do
        With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchWildcards = True
'Find a str between a tab & the nearest previous para sign:
            .text = "^13[!^13]@^t"
            If .Execute And rng.End <= rngEnd Then
                .text = "[,:; ]"
                .Replacement.text = "."
                .Execute Replace:=wdReplaceAll
            Else: Exit Do
            End If
'Delete a period before a tab:
            If rng.Characters.Last.Previous = "." Then
                 rng.Characters.Last.Previous.Delete
            End If
            rng.Collapse wdCollapseEnd
        End With
    Loop
'Insert periods after lone 1st-level numberings:
    Set rng = ActiveDocument.range
     With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
        .text = "(^13[0-9]{1;})^t"
        .Replacement.text = "\1.^t"
        .Execute Replace:=wdReplaceAll
    End With
ActiveDocument.range.Characters.First.Delete
Application.ScreenUpdating = True
Set rng = Nothing
 End Sub

Note: you may need to replace ';' with ',' in {1;}.

Shelley Lou · #5 08-06-2024, 03:17 AM

Hi Vivka, thank you so much for the updated code, I have struggled for a long time doing all those changes manually. I was getting an error with this part part of the code...

Code:

 .text = "(^13[0-9]{1;})^t"
        .Replacement.text = "\1.^t"
        .Execute Replace:=wdReplaceAll

so I have updated the code to this which seems to work

Code:

.text = "(^13[0-9]{1,})([ ^t])"
        .Replacement.text = "\1.^t"
        .Execute Replace:=wdReplaceAll

vivka · #6 08-06-2024, 03:28 AM

However I think you could use the following, because your errors were due to ; instead of , in figure brackets, not due to additional () (see the Note in my previous post)

Code:

.text = "(^13[0-9]{1,})^t" 
.Replacement.text = "\1.^t"
.Execute Replace:=wdReplaceAll

Shelley Lou · #7 08-06-2024, 05:20 AM

Hi Vivka, yes that works - just come across another little issue which I hadn't accounted for which is if there is a space and not a tab, how do I change this line of code to look for either a space or a tab?

Code:

.text = "^13[!^13]@^t"

vivka · #8 08-06-2024, 08:41 AM

Hi, Shelley Lou! You can change your code to

Code:

.text = "^13[!^13]@[^t ]"

But this may bring about new problems because spaces are everywhere in the text including between numbers in multi-level lists (e.g.: 2 2.2tabfolllowing a written...). As a remedy, I would replace all digit-letter spaces with tabs and then run the original code. Or, please, post a new (more complex, including as many numbering cases as possible) sample of your doc to try different code changes on.

Shelley Lou · #9 08-06-2024, 08:48 AM

Hi Vivka, yes I did try that variation but it didn't work for me. I've attached an updated test document so you can see what I mean with regard to the spaces - not sure how to get around this.

format manual numbering before running auto numbering code.docx

vivka · #10 08-06-2024, 10:49 AM

Hi again, Shelley Lou! I think we did it at last! The code has bloated but it works properly in (as I think) all possible cases (see the attached test doc modified by me).

Code:

Sub FormatManualNumbering()
'In active doc, format multi-level manual numbering.

Dim rng As range
Dim rngEnd As Long

Application.ScreenUpdating = False
    Set rng = ActiveDocument.range
    rngEnd = rng.End
    rng.Characters.First.InsertBefore Chr(13)
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
        .text = "(^13[!^13]@)([A-Za-z])"
        .Replacement.text = "\1^t\2"
        .Execute Replace:=wdReplaceAll
        .text = "^t^t"
        .Replacement.text = "^t"
        .Execute Replace:=wdReplaceAll
    End With
    Do
        With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchWildcards = True
            .text = "^13[!^13]@^t"
            If .Execute And rng.End <= rngEnd Then
                .text = "[,:; ]"
                .Replacement.text = "."
                .Execute Replace:=wdReplaceAll
            Else: Exit Do
            End If
            If rng.Characters.Last.Previous = "." Then
                rng.Characters.Last.Previous.Delete
            End If
            rng.Collapse wdCollapseEnd
        End With
    Loop
    Set rng = ActiveDocument.range
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
        .text = "(^13[0-9]{1;})^t"
        .Replacement.text = "\1.^t"
        .Execute Replace:=wdReplaceAll
    End With
ActiveDocument.range.Characters.First.Delete
Application.ScreenUpdating = True
Set rng = Nothing
End Sub

Shelley Lou · #11 08-08-2024, 08:21 AM

Hi Vivka, thanks for taking the time to update the code - unfortunately your code did not work for me, it threw up a few issues. I've posted a couple of images below.

Code not removing the very last at the end of levels 2-4 consistently
Capture1.JPG

Code separating text with a tab
Capture2JPG.JPG

I've added this to the beginning of the code which isn't ideal as it can't capture any other rogue punctuation without it affecting the rest of the document text e.g. instances at the end of paragraphs containing a semi colon (; and). Not as easy as I thought!!

Code:

Set rng = ActiveDocument.Range
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
        .text = "([.])([ ])([A-Za-z])"
        .Replacement.text = "^t\3"
        .Execute Replace:=wdReplaceAll
    End With

vivka · #12 08-09-2024, 05:31 AM

Hi, Shelley Lou! I hope the following code will do what you need:

Code:

Sub FormatManualNumbering()
'In active doc, format multi-level manual numbering.

Dim rng As range
Dim rngEnd As Long

Application.ScreenUpdating = False
    Set rng = ActiveDocument.range
    rng.Characters.First.InsertBefore Chr(13)
    rngEnd = rng.End
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
        .text = "(^13[!^13]@)([A-Za-z])"
        .Replacement.text = "\1^t\2"
        .Execute Replace:=wdReplaceAll
        .text = "^t^t"
        .Replacement.text = "^t"
        .Execute Replace:=wdReplaceAll
        .text = "([A-Za-z])^t([A-Za-z])"
        .Replacement.text = "\1\2"
        .Execute Replace:=wdReplaceAll
    End With
    Set rng = ActiveDocument.range
    Do
        With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchWildcards = True
            .text = "^13[!^13]@^t"
            If .Execute And rng.End <= rngEnd Then
                .text = "[,:; ]"
                .Replacement.text = "."
                .Execute Replace:=wdReplaceAll
            Else: Exit Do
            End If
            While rng.Characters.Last.Previous = "."
                rng.Characters.Last.Previous.Delete
            Wend
            rng.Collapse wdCollapseEnd
        End With
    Loop
    Set rng = ActiveDocument.range
    With rng.Find
         .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
        .text = "(^13[0-9]{1;})^t"
        .Replacement.text = "\1.^t"
        .Execute Replace:=wdReplaceAll
    End With
ActiveDocument.range.Characters.First.Delete
Application.ScreenUpdating = True
Set rng = Nothing
End Sub

Shelley Lou · #13 08-13-2024, 02:19 AM

Hi Vivka, thank you for the updated code, always appreciated. I've been testing it for the past couple of days, the code works for the most part but I came across this issue today which I haven't come across before, where there is punctuation and a space between the digits, when the code has run it converts to a double period. I'm trying to work out what I can add at the end of the code to replace to just one period.

Before code is run
Capture1.JPG

After code has run
Capture2JPG.JPG

test format manual numbering.docx

vivka · #14 08-13-2024, 03:15 AM

Hi, Shelley Lou! No one & nothing is perfect! This final variant is hopefully what you need. I've added three lines to the last With-End With to replace two & more periods in the doc. I've added comments to the code to facilitate its understanding.

Code:

Sub FormatManualNumbering()
'In active doc, format multi-level manual numbering.

Dim rng As range
Dim rngEnd As Long

Application.ScreenUpdating = False
    Set rng = ActiveDocument.range
'Insert a para sign at the doc's start to include the doc's 1st para in work:
    rng.Characters.First.InsertBefore Chr(13)
     rngEnd = rng.End
    With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
'Insert a tab before any 1st letter in a para:
        .text = "(^13[!^13]@)([A-Za-z])"
        .Replacement.text = "\1^t\2"
        .Execute Replace:=wdReplaceAll
'Replace two tabs with one tab:
        .text = "^t^t"
        .Replacement.text = "^t"
        .Execute Replace:=wdReplaceAll
'Delete tabs between letters, which have been inserted earlier:
        .text = "([A-Za-z])^t([A-Za-z])"
        .Replacement.text = "\1\2"
        .Execute Replace:=wdReplaceAll
    End With
'Running the next Find-Replace causes run-time error 5623
'(The Replace With text contains a group number which is out of range)
'which may occur because the parameters of Find-Replace may be kept in the next use of Find-Replace.
'Resetting rng is one of the ways to correct the error:
    Set rng = ActiveDocument.range
    Do
        With rng.Find
            .ClearFormatting
            .Replacement.ClearFormatting
            .Forward = True
            .Wrap = wdFindStop
            .Format = True
            .MatchWildcards = True
'Find a str between a tab & the nearest previous para sign, i.e.
'a str between a para sign & a tab, excluding other paras in-between:
            .text = "^13[!^13]@^t"
'Within the found str replace all series of commas, colons, semicolons & spaces with a period:
            If .Execute And rng.End <= rngEnd Then
                 .text = "[,:; ]"
                .Replacement.text = "."
                .Execute Replace:=wdReplaceAll
            Else: Exit Do
            End If
'Delete all periods immediately before a tab:
            While rng.Characters.Last.Previous = "."
                rng.Characters.Last.Previous.Delete
            Wend
            rng.Collapse wdCollapseEnd
        End With
    Loop
'Reset rng (see the comment above):
    Set rng = ActiveDocument.range
    With rng.Find
         .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = True
        .MatchWildcards = True
'Insert periods after lone 1st-level numberings:
        .text = "(^13[0-9]{1;})^t"
        .Replacement.text = "\1.^t"
        .Execute Replace:=wdReplaceAll
'Delete extra periods in the doc:
        .text = "[.]{2;}"
        .Replacement.text = "."
        .Execute Replace:=wdReplaceAll
    End With
'Delete the doc's starting para sign inserted previously:
    ActiveDocument.range.Characters.First.Delete
 Application.ScreenUpdating = True
Set rng = Nothing
End Sub

I had some free time, so I've compiled another codes to do the job. One of them is your tuned initial code, which happened to be the fastest one, but it is a little complicated for reading. I hope the code I'm posting, although long, is quite readable & effective.
And I am ready for new challenges!

Shelley Lou · #15 08-13-2024, 08:57 AM

Hi Vivka, OMG thanks so much for the updated code and thank you for adding comments, it makes it so much easier to read/understand - thank you for taking the time.

I'm just adding one last thing to the end of the code where the code is inserting a tab after an opening bracket - I added code to remove the tab but it only appears to remove the first instance (in the image at (a)) and not the rest (from (b) onwards) - have I not got the replacement text correct?

Code:

 'Delete tab after opening bracket:
        .text = "^13[\(]^t"
        .Replacement.text = "^p\1("
        .Execute Replace:=wdReplaceAll

Capture.JPG

Format manual numbering with brackets.docx

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
VBA insert period after manual numbering	Shelley Lou	Word VBA	1	03-05-2023 03:45 AM
VBA Remove manual numbering after Outline numbering	Shelley Lou	Word VBA	2	08-04-2021 12:24 AM
VBA converting manual numbering to auto numbering	Shelley Lou	Word VBA	8	05-28-2021 01:08 AM
Applying New Multi-Level List to Existing Document with Manual Numbering and Existing Styles	stanley	Word	4	12-15-2020 10:59 AM
page numbering for manual	Bursal	Word	1	07-29-2018 02:08 PM