VBA Format manual numbering so auto numbering code can run

vivka · #1 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 · #2 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 · #3 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 · #4 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

vivka · #5 08-13-2024, 09:54 AM

Hi, again!

I would use

Code:

        .text = "(^13[(])^t"
        .Replacement.text = "\1"
        .Execute Replace:=wdReplaceAll

Shelley Lou · #6 08-14-2024, 06:34 AM

Hi Vivka, aaaah yes that was a combination I didn't think of so thank you for that. I have now further updated the code which removes any white space after paragraph marks and before paragraph marks and also the removal of any empty paragraphs. At the end of the code I've had to include removing a tab after an opening double quote - not sure if you would have done something different with my additions. Thank you so much for your patience with me in getting this code to work as I needed it to, I really appreciate the help you have provided.

Code:

Sub FormatManualNumbering()
Dim rng As Range
Dim rngEnd As Long
On Error GoTo Err_Handler:
Application.ScreenUpdating = False
Set rng = ActiveDocument.Range
With ActiveDocument.Range
  .InsertBefore vbCr
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindContinue
    .Format = False
    .MatchWildcards = False
'Removes leading spaces at beginning of paragraphs
    .text = "^p^w"
    .Replacement.text = "^p"
    .Execute Replace:=wdReplaceAll
    .text = "^w^p"
    .Execute Replace:=wdReplaceAll
  End With
  .Characters.First.text = vbNullString
End With
Set rng = ActiveDocument.Range
  With rng.Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Forward = True
    .Wrap = wdFindStop
    .Format = True
    .MatchWildcards = True
 'Remove empty paras:
    .text = "^13{2,}"
    .Replacement.text = "^p"
    .Execute Replace:=wdReplaceAll
End With
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
'Code_1. Insert a tab before any 1st letter in a para:
        .text = "(^13[!^13]@)([A-Za-z])"
        .Replacement.text = "\1^t\2"
        .Execute Replace:=wdReplaceAll
'Code_2. Replace two tabs with one tab:
        .text = "^t^t"
        .Replacement.text = "^t"
        .Execute Replace:=wdReplaceAll
'Code_3. Delete tabs between letters, which have been inserted by Code_1:
        .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"
            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
 'Delete tab after opening bracket:
        .text = "(^13[(])^t"
        .Replacement.text = "\1"
        .Execute Replace:=wdReplaceAll
 'Delete tab after opening double quote after para marks:
        .text = "(" & Chr(34) & ")^t([!^13])"
        .Replacement.text = "\1\2"
        .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
Err_Handler:
End Sub

Thread Tools
Show Printable Version Email this Page
Display Modes
Switch to Linear Mode Hybrid Mode Switch to Threaded Mode

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