VBA Format manual numbering so auto numbering code can run

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

Hi, again!

I would use

Code:

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

Shelley Lou · #17 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

vivka · #18 08-14-2024, 10:08 AM

Hi, Shelley Lou! I have made minor changes to your last code (I think they are justified; see comments). Seems to work properly. However only God knows...

Code:

Sub FormatManualNumbering()

Dim rng As range
Dim rngEnd As Long
    
    Application.ScreenUpdating = False
    Set rng = ActiveDocument.range
    rngEnd = rng.End
    ActiveDocument.range.InsertBefore vbCr
       With rng.Find
        .ClearFormatting
        .Replacement.ClearFormatting
        .Forward = True
        .Wrap = wdFindStop
        .Format = False
        .MatchWildcards = False
'Remove spaces starting paras:
        .text = "^p^w"
        .Replacement.text = "^p"
        .Execute Replace:=wdReplaceAll
'Remove spaces before para signs:
        .text = "^w^p"
        .Replacement.text = "^p"
        .Execute Replace:=wdReplaceAll
'Remove empty paras:
        .MatchWildcards = True
        .text = "^13{2,}"
        .Replacement.text = "^p"
        .Execute Replace:=wdReplaceAll
'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 using
'the code to insert a tab before any 1st letter in a para previously:
        .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 (Chr(34) & Chr(147))
'after para marks:
        .text = "(^13" & "[" & Chr(34) & Chr(147) & "]" & ")^t"
        .Replacement.text = "\1"
        .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

Shelley Lou · #19 08-15-2024, 12:53 AM

Hi Vivka, thanks for the revised code which I tested this morning - unfortunately couldn't get it to work correctly - I did a step through the code to see what wasn't working and it appears this section of the code failed to update anything so not sure how to fix that.

Code:

 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

vivka · #20 08-15-2024, 01:19 AM

Hi, Shelley Lou! I lost one line (rngEnd = rng.End) when edited the code (the code is quite lengthy). Now I've made the correction in Post 18. Please, test the code.

gmaxey · #21 08-15-2024, 02:28 AM

Shelley Lou, vivka,

I have been following this thread with interest and rather enjoying its development. Thought I would chime in with a different approach. While this approach introduces code that will naturally take longer to run, if the documents are not too large it may not matter.

Code:

Option Explicit
Private oRngNum As Range
Sub FormatManualNumbering()
Dim oRng As Range
Dim oPar As Paragraph
    Application.ScreenUpdating = False
    Set oRng = ActiveDocument.Range
    oRng.InsertBefore vbCr
    With oRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = False
      'Remove spaces starting paras:
      .Text = "^p^w"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
    End With
    oRng.Characters(1).Delete
    For Each oPar In oRng.Paragraphs
      If IsNumeric(oPar.Range.Characters(1)) Then
        Set oRngNum = oPar.Range
        oRngNum.Collapse wdCollapseStart
        Do Until oRngNum.Characters.Last.Next Like "[A-Za-z]"
          oRngNum.MoveEnd wdCharacter, 1
        Loop
        ProcessNum
      End If
    Next
   Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub
Sub ProcessNum()
Dim oRng As Range
Dim lngIndex As Long
Dim bAllNums As Boolean
  bAllNums = True
  Set oRng = oRngNum.Duplicate
  oRng.Collapse wdCollapseEnd
  Do Until IsNumeric(oRng.Characters.First.Previous)
    oRng.MoveStart wdCharacter, -1
  Loop
  oRng.Text = "." & vbTab
  oRngNum.End = oRng.Start
  For lngIndex = 1 To oRngNum.Characters.Count
    If Not IsNumeric(oRngNum.Characters(lngIndex)) Then
      oRngNum.Characters(lngIndex) = "."
      bAllNums = False
    End If
  Next
  If Not bAllNums Then oRngNum.Characters.Last.Next.Delete
lbl_Exit:
  Exit Sub
End Sub

vivka · #22 08-15-2024, 03:06 AM

Gmaxey, thank you for another approach! I also have compiled two more macros using slightly different approaches but I didn't post them here not to confuse Shelley Lou with too many solutions. As to me I am always eager to learn something new. Thank you!

Shelley Lou · #23 08-15-2024, 07:32 AM

Hi Vivka, you are a gem - tested code and all seems to be working correctly - thank you so much

vivka · #24 08-15-2024, 11:48 AM

You are welcome, Shelley Lou! And thank you for an interesting challenge! Besides, thanks to the site's administration for pomoting me to the rank of expert (which I am not)! It's very inspiring and a great responsibility!

Shelley Lou · #25 09-28-2024, 12:40 AM

My absolute apologies Greg, I'm not sure why but I didn't see this post at all. I've tested your code on quite a large document and it worked quite quickly. The only issue I found is if the numbering has a period and space, the codes makes it a double period, other than that it is bloomin brilliant - thank you so much

Before.JPG
After.JPG

Quote:

Originally Posted by gmaxey

Shelley Lou, vivka,

I have been following this thread with interest and rather enjoying its development. Thought I would chime in with a different approach. While this approach introduces code that will naturally take longer to run, if the documents are not too large it may not matter.

Code:

Option Explicit
Private oRngNum As Range
Sub FormatManualNumbering()
Dim oRng As Range
Dim oPar As Paragraph
    Application.ScreenUpdating = False
    Set oRng = ActiveDocument.Range
    oRng.InsertBefore vbCr
    With oRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = False
      'Remove spaces starting paras:
      .Text = "^p^w"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
    End With
    oRng.Characters(1).Delete
    For Each oPar In oRng.Paragraphs
      If IsNumeric(oPar.Range.Characters(1)) Then
        Set oRngNum = oPar.Range
        oRngNum.Collapse wdCollapseStart
        Do Until oRngNum.Characters.Last.Next Like "[A-Za-z]"
          oRngNum.MoveEnd wdCharacter, 1
        Loop
        ProcessNum
      End If
    Next
   Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub
Sub ProcessNum()
Dim oRng As Range
Dim lngIndex As Long
Dim bAllNums As Boolean
  bAllNums = True
  Set oRng = oRngNum.Duplicate
  oRng.Collapse wdCollapseEnd
  Do Until IsNumeric(oRng.Characters.First.Previous)
    oRng.MoveStart wdCharacter, -1
  Loop
  oRng.Text = "." & vbTab
  oRngNum.End = oRng.Start
  For lngIndex = 1 To oRngNum.Characters.Count
    If Not IsNumeric(oRngNum.Characters(lngIndex)) Then
      oRngNum.Characters(lngIndex) = "."
      bAllNums = False
    End If
  Next
  If Not bAllNums Then oRngNum.Characters.Last.Next.Delete
lbl_Exit:
  Exit Sub
End Sub

gmaxey · #26 09-28-2024, 10:49 AM

Shelly,

You will have to test of course, but replace the existing ProcessNum procedure with:

Code:

Sub ProcessNum()
Dim oRng As Range
Dim lngIndex As Long
Dim bAllNums As Boolean
  bAllNums = True
  Set oRng = oRngNum.Duplicate
  oRng.Collapse wdCollapseEnd
  Do Until IsNumeric(oRng.Characters.First.Previous)
    oRng.MoveStart wdCharacter, -1
  Loop
  oRng.Text = "." & vbTab
  oRngNum.End = oRng.Start
  For lngIndex = 1 To oRngNum.Characters.Count
    If Not IsNumeric(oRngNum.Characters(lngIndex)) Then
      If Not oRngNum.Characters(lngIndex) = " " Then
        oRngNum.Characters(lngIndex) = "."
        bAllNums = False
      End If
    End If
  Next
  If Not bAllNums Then oRngNum.Characters.Last.Next.Delete
lbl_Exit:
  Exit Sub
End Sub

Shelley Lou · #27 09-30-2024, 03:58 AM

Hi Greg, thank you for the updated code. Unfortunately it hasn't worked as we thought it would. It hasn't removed the space after the period and in 1.3 1 it hasn't put the period in. I've gone back to your original code for the time being as apart from the double period issue, the code worked better.

Before.JPG
After.JPG

gmaxey · #28 09-30-2024, 05:58 AM

Shelly,

It is hard to tell what you want the code to do without and sample before and after document attached. You can try:

Code:

Sub ProcessNum()
Dim oRng As Range
Dim lngIndex As Long
Dim bAllNums As Boolean
  bAllNums = True
  Set oRng = oRngNum.Duplicate
  oRng.Collapse wdCollapseEnd
  Do Until IsNumeric(oRng.Characters.First.Previous)
    oRng.MoveStart wdCharacter, -1
  Loop
  oRng.Text = "." & vbTab
  oRngNum.End = oRng.Start
  For lngIndex = 1 To oRngNum.Characters.Count
    If Not IsNumeric(oRngNum.Characters(lngIndex)) Then
      If oRngNum.Characters(lngIndex) = " " And oRngNum.Characters(lngIndex).Previous = "." Then
        oRngNum.Characters(lngIndex).Delete
        lngIndex = lngIndex + 1
      Else
        oRngNum.Characters(lngIndex) = "."
        bAllNums = False
      End If
    End If
  Next
  If Not bAllNums Then oRngNum.Characters.Last.Next.Delete
lbl_Exit:
  Exit Sub
End Sub

Shelley Lou · #29 09-30-2024, 06:34 AM

Hi Greg, I have attached before being rund, after being run and what the code should do after being run if that helps.

Before.docx

Attachment 20943

Attachment 20942

gmaxey · #30 09-30-2024, 06:44 AM

Shelly,

We have better things to do than look for needles in haystacks. Can you please indicate what is wrong in the After.docx after the code is run.

Code:

Option Explicit
Private oRngNum As Range
Sub FormatManualNumbering()
Dim oRng As Range
Dim oPar As Paragraph
    Application.ScreenUpdating = False
    Set oRng = ActiveDocument.Range
    oRng.InsertBefore vbCr
    With oRng.Find
      .ClearFormatting
      .Replacement.ClearFormatting
      .Forward = True
      .Wrap = wdFindStop
      .Format = False
      .MatchWildcards = False
      'Remove spaces starting paras:
      .Text = "^p^w"
      .Replacement.Text = "^p"
      .Execute Replace:=wdReplaceAll
    End With
    oRng.Characters(1).Delete
    For Each oPar In oRng.Paragraphs
      If IsNumeric(oPar.Range.Characters(1)) Then
        Set oRngNum = oPar.Range
        oRngNum.Collapse wdCollapseStart
        Do Until oRngNum.Characters.Last.Next Like "[A-Za-z]"
          oRngNum.MoveEnd wdCharacter, 1
        Loop
        ProcessNum
      End If
    Next
   Application.ScreenUpdating = True
lbl_Exit:
  Exit Sub
End Sub
Sub ProcessNum()
Dim oRng As Range
Dim lngIndex As Long
Dim bAllNums As Boolean
  bAllNums = True
  Set oRng = oRngNum.Duplicate
  oRng.Collapse wdCollapseEnd
  Do Until IsNumeric(oRng.Characters.First.Previous)
    oRng.MoveStart wdCharacter, -1
  Loop
  oRng.Text = "." & vbTab
  oRngNum.End = oRng.Start
  For lngIndex = 1 To oRngNum.Characters.Count
    If Not IsNumeric(oRngNum.Characters(lngIndex)) Then
      If oRngNum.Characters(lngIndex) = " " And oRngNum.Characters(lngIndex).Previous = "." Then
        oRngNum.Characters(lngIndex).Delete
        lngIndex = lngIndex + 1
      Else
        oRngNum.Characters(lngIndex) = "."
        bAllNums = False
      End If
    End If
  Next
  If Not bAllNums Then oRngNum.Characters.Last.Next.Delete
lbl_Exit:
  Exit Sub
End Sub

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