The problem

Word doesn't really know how to handle numbering when it comes to multiple separated lists. e.g.

Some text describing a set of points:

   a. item 1.1

   b. item 2

More text describing the next set of points:

   c. widget 1 <-- this should say a. widget 1

   d. widget 2 <-- this should say b. widget 2

They seem to have a mind of their own - they restart their number, or the lists aren't joined properly, or they skip numbers. Sometimes if you copy paste a numbered list in, all the numbers change in other lists as well.

There are quite a macros floating around that fix some problems with numbering. But they don't seem to work in all cases and they are slow because of the way Word handles styles.

Here's a set of macros that I've written, that IMHO works much better, faster, and more consistently. 

• 1. RestartLists goes through the document from the current cursor position and restarts all the lists after this point.

     1.  

  2. ContinueListsFast quickly resets all the numbering through the whole document so everything is one single huge list. You should do this first before RestartLists.

     1.  

  3. ContinueListsSlow is a slower more traditional programmatic way, similar to other macros you'll find on the interwebs. But boy it is slow. Only use this if for some reason the fast method doesn't work.

How to use

• 1. Assign a style ("Sub Para List" is the default) to each and every numbered list you want it to fix. It won't touch any other lists.

  2. Select the region you want to fix.

  3. Run RestartLists.

How it works

I've chosen to use a reasonable method of determining when to restart lists: If the previous paragraph isn't a list item, then this paragraph must be a new list! 

This logic is what most people use when starting a new list. It's sensible and conventional. 

To ensure that each list is one single list, the macro deletes the carriage return and reinserts it. Otherwise Word seems to associate each list with the very first list in the document which is really strange and annoying (see first picture above on this web page, and see below picture for the final fixed numbered lists after you run this macro).

NOTE: If you need to have an unnumbered paragraph nestled within a list, you should consider using line breaks (SHIFT-ENTER) instead of paragraph breaks. Using line breaks will also ensure that indenting is preserved. Don't do strange things like turn off numbering for that paragraph. Technically this text is part of the same numbered item so it should be in the same paragraph. 

NOTE: If your list already has manual restarts in it and you want to reset the numbering, then run the macro further down to continue all the numbering first.

NOTE: If you are using sublevels, this macro will not alter the values. It doesn't seem to be possible to properly associate lists with sublevels to separate galleries.

The code 

Sub RestartLists()

' Restarts all lists where the previous paragraph is not the numbering style.

' Select the text you wish to fix.

' Edward Chan 2025

    Application.ScreenUpdating = False

    Dim listName As String

    Dim prevParaName As String

    Dim mypara As Paragraph

    Dim boolRestart As Boolean

    Dim scope As Range      ' The original selection

    Dim found As Boolean    ' Flag saying that the word has been found

    Dim foundRange As Range ' Where the word had been found currently

    Dim startHere As Range ' Keeps track of where Word is up to in the search

    Dim myRange As Range

    Set scope = Selection.Range

    Set foundRange = Selection.Range

    ' Check if anything is selected. If nothing is selected then let the user know they

    ' need to select a section.

    If Selection.Start = Selection.End Then

        MsgBox ("Please select a range first. Tip: To select an entire section easily, View > Navigation Pane > right-click the heading > Select Heading and Content")

        Exit Sub

    End If

    ' Set bookmark for return.

    ActiveDocument.Bookmarks.Add Name:="WhereYouWere", Range:=Selection.Range

  ' ListName for the style of the list.

    listName = InputBox("Enter the Style name of the List that you wish to renumber", , "List")

    With foundRange.Find

        .ClearFormatting

        .Style = ActiveDocument.Styles(listName)

        .Forward = True

        .Wrap = wdFindStop

    End With

    found = foundRange.Find.Execute ' https://learn.microsoft.com/en-us/office/vba/api/word.find

                                    ' If you've gotten to the Find object from the Range object,

                                    ' the selection isn't changed when text matching the find criteria

                                    ' is found, but the Range object is redefined.

    While (found)

        ' Check if it's still in the range since Find will keep searching entire

        ' doc if the range is empty, which can happen if the last para is one of the search results

        If Not foundRange.InRange(ActiveDocument.Bookmarks("WhereYouWere").Range) Then

            found = False ' It's not actually in the range, the find command has jumped over the selection

        Else

            Set mypara = foundRange.Paragraphs(1)

            On Error Resume Next

            If mypara.Previous.Style Is Nothing Then prevParaName = " " Else prevParaName = mypara.Previous.Style ' get around strange string comparison bug when the style is empty

            On Error GoTo 0

            ' New List

            If Left(prevParaName, Len(listName)) <> listName Then

                ' Restart numbering since previous para is not part of the para numbering set (e.g. List, List 2)

                DoEvents ' Required to ensure that CTRL-BREAK or ESC ESC ESC will work.

                ' Check if it's already restarted, if so don't do anything (to avoid breaking the entire list)

                If mypara.Range.ListFormat.ListLevelNumber = 1 Then

                    ' do nothing, it's already the start of a list. If you try to restart the list again,

                    ' it will break the rest of the list as it creates a new internal hidden

                    ' list gallery item.

                Else

                    ' It's not the start but it should be.

                    mypara.Style = listName ' Set the style again to reset the gallery to the default list style

                    mypara.Range.Select

                    ' Click the "Restart Numbering" button. It's the only way to reset numbering reliably.

                    ' See https://stackoverflow.com/questions/7010478/word-2007-use-commands-via-macro

                    ' See https://www.thedoctools.com/index.php?show=wt_find_command

                    Selection.MoveLeft Unit:=wdCharacter, Count:=1

                    On Error Resume Next

                    Application.Run MacroName:="RestartNumbering"

                    On Error GoTo 0

                    Selection.Find.Execute

                End If

            ElseIf prevParaName = listName Then

                ' It's not the first item in the list and the previous is not a sublevel like List 2

                ' So continue numbering by deleting number and pressing enter to force genuine

                ' continuation like a real person would.

                Set myRange = mypara.Range

                ' Well that was overthinking it. Apparently you just need to

                ' delete the previous charater and press enter to continue,

                ' and this also fixes the separated lists at the same time. Nice.

                myRange.Collapse (wdCollapseStart)

                myRange.Select

                Selection.TypeBackspace

                Selection.TypeParagraph

            Else

                ' It's a continuation of a list, don't do anything. Assume the Author

                ' knows what they are doing - if it's wrong the author will need

                ' to manually fix it as it would require re-doing the entire list again.

                ' and it would be too complicated to automate easily, as there are

                ' many ways of defining a sub-para list and there may be breaks on purpose.

            End If

            ' Find next occurrence in the selection

            foundRange.Collapse (wdCollapseEnd) ' Go to the end of the found text

            Set startHere = foundRange          ' Store the new starting position (which is just after what was found)

            Set foundRange = ActiveDocument.Bookmarks("WhereYouWere").Range ' Set the range back to the original selection since

                                   ' foundrange currently points to the blanked text location

            foundRange.Start = startHere.Start ' Reset the starting position to where the last search was found

            With foundRange.Find ' Undocumented behaviour of Find function means that you

                                 ' need to reset the range each time if you change the

                                 ' start or end of a found range.

                .ClearFormatting

                .Style = ActiveDocument.Styles(listName)

                .Forward = True

                .Wrap = wdFindStop

            End With

            found = foundRange.Find.Execute

        End If

    Wend

    Application.ScreenRefresh

    Application.ScreenUpdating = True

    Selection.GoTo What:=wdGoToBookmark, Name:="WhereYouWere"

    ActiveDocument.Bookmarks("WhereYouWere").Delete

    MsgBox "The selected text has had its numbering restarted where needed. Please double-check to ensure it is correct.", vbInformation

End Sub

Continuing Lists

If there are lots of lists that have been restarted, then run one of the following macros (change the predefined list name to suit).

Sub ContinueListsFast()

' This subroutine selects all instances of a defined style and changes it to "Continue Lists"

' Edward Chan 2017

'

  Dim listName As Style

  ' Set bookmark for return.

  ActiveDocument.Bookmarks.Add Name:="WhereYouWere", Range:=Selection.Range

  ' ListName for the style of the list.

  Set listName = ActiveDocument.Styles("Sub Para List")

  Selection.Find.ClearFormatting

  Selection.Find.Style = listName

  With Selection.Find

    .Text = ""

    .Replacement.Text = ""

    .Forward = True

    .Wrap = wdFindContinue

    .Format = True

    .MatchCase = False

    .MatchWholeWord = False

    .MatchWildcards = False

    .MatchSoundsLike = False

    .MatchAllWordForms = False

  End With

  Selection.Find.Execute

  ' Emulate the "Find All" button

  WordBasic.SelectSimilarFormatting

  ' Need to click the "Continue Numbering" button. It's the only way to continue numbering reliably.

  ' See https://www.pcreview.co.uk/threads/program-click-on-ribbon-button-using-vba.3919025/

  ' Office 2010 IDs: https://www.microsoft.com/en-gb/download/details.aspx?id=6627

  CommandBars.FindControl(ID:=6125).Execute

  Selection.GoTo What:=wdGoToBookmark, Name:="WhereYouWere"

  ActiveDocument.Bookmarks("WhereYouWere").Delete

End Sub

Sub ContinueListsSlow()

' Continues all lists of a certain numbering style.

' It starts from the current cursor location.

' It's pretty slow because Word is slow when applying a list template.

' Edward Chan 2017

  Dim listName As String

  Dim myPara As Paragraph

  Dim boolRestart As Boolean

    ' Set bookmark for return.

    ActiveDocument.Bookmarks.Add Name:="WhereYouWere", Range:=Selection.Range

  ' ListName for the style of the list.

    listName = "Sub Para List"

    Selection.Find.ClearFormatting

    Selection.Find.Style = ActiveDocument.Styles(listName)

    Selection.Find.Execute

    While Selection.Find.Found

        DoEvents

        Selection.MoveLeft Unit:=wdCharacter, Count:=1

        Selection.Paragraphs(1).ResetAdvanceTo

        Selection.Paragraphs(1).SelectNumber

        Selection.Range.ListFormat.ApplyListTemplateWithLevel ListTemplate:= _

            ActiveDocument.Styles(listName).ListTemplate, ContinuePreviousList:=True

        Selection.Find.Execute

        Selection.Find.Execute

    Wend

    Selection.GoTo What:=wdGoToBookmark, Name:="WhereYouWere"

    ActiveDocument.Bookmarks("WhereYouWere").Delete

End Sub

Here are some other macros from https://www.freelists.org/post/austechwriter/atw-Re-Word-Numbering-Issues-Save-my-life-please,6

I haven't really explored these, and it uses a different method (by avoiding numbered styles completely).

www.freelists.org /post/austechwriter/atw-Re-Word-Numbering-Issues-Save-my-life-please,6

atw: Re: Word Numbering Issues! Save my life, please!

• From: "Steve Hudson" <cruddy@xxxxxxxxxxxxxxxx>

• To: <austechwriter@xxxxxxxxxxxxx>

• Date: Mon, 22 Sep 2003 21:52:35 +1000

I posted the macros here on their first release.

In a nutshell, Word's styles do not allow for the "Restart Numbering"

property. MS refuses to make it so. So we're basically screwed. Word Perfect

is fully compatible and does the job nicely. However, this doesn't help us

here right ;-)

If you have auto-update on, that restart property is manual formatting and

gets blown by the style redef from the auto thingy. Not good.

However, even WITH auto-updates off, your lists can still be in diabolical

trouble through naivette. Ce sera sera. So, rather than building enormously

complex tools to deal with every situation, I have released the code for a

set of macros I have been using for years in order to control my output so

that you can tailor them up for yourself.

At the end of the day, you have several options.

You can purchase my spellbooks and read up on lists. There are other,less

extensive sources as well.

You could pay me to create you beautiful raw style templates with your

desired numbering and a bunch of macros to enforce them. If you need urgent

help, +61 (0) 422233044.

The various sites have, for one reason or another, failed to post up my

macros despite their usage being not only in the thousands but also taught

at universities with my permission. <Shrugs> So, you can just twiddle with

these and get on with life in a basic fashion. Err, to answer that last

part - they are FREE. Customizing them is commercial, basic access is not

:-)

REPOST

___________________________________________________________-

The Long Awaited Heretical List Fixes

=====================================

This needs lot of work!!!!

Here be a long mess of code. If you haven't learnt about VBA, see the so

named tab on the index of this site for easy tutorials to get you started.

However, this is the equivalent to the deep end of the Word pool so tread

water lightly - somewhat like this metaphor.

It is not perfect, but it is an excellent start. Some of the uses are not so

intuitive, for example, before you do ANY operation that inviolably screws

up list numbering - just convert to text and convert back. Outline numbered

lists can be dealt with via an extension of the provided code which I am

sure someone will be good enough to provide at some future date but which

looks at the number of tabs or indent settings and sets the list level

accordingly.

You should always run the report on your styles first, and ensure they are

set correctly in your templates. Once this is done, you can run riot with

updating styles with a find n replace and using restart lists after headings

to fix up restart points.

The key thing to note is that it is a lot easier to customize some existing

VBA to solve these problems than it is to provide a generic tool to

generically solve all the problems. Don't worry about all permutations, just

worry about the stuff that's in front of you, make this code fit it and

solve your headaches.

OneStyle was to be the key to whether you used a single style for your

outline list levels, or multiple. If just one style, then this should be

true and things should sorta work as I planned.

Bar is commented out - it is in heretic.dot and is just a simple progress

bar that's badly implemented by the above. I really should check for display

alerts to allow simple signalling of whether to can the UI.

I use this as a class object, but there is little stopping you from using it

as a code module if you want to clutter your interface all the time. Just

insert my extracts at the end in after the code in the same object, I

removed all references to them for you already (I hope!). If you would

prefer me to tailor this up for you as a commercial service, you can contact

me at the email address below.

There's an awful lot of code here, with an awful lot of time put into this -

that's years kids. If you extend it any direction I would love to hear from

you.  I keep the copyright on it, but have given permission for Word MVPs to

distribute it from their website. You may not include this code, or derivati

ves of it, in any commercial software without my permission. If you wish to

distribute modified copies for free to over 500 people, you will also need

to contact me for permission.

steve@xxxxxxxxxxxxxxx

__ Global constants, best off in their own code mod ___

#If VBA6 Then

Public Enum hitListTemplateLoc

   hitListTemplatesInListGalleries = 1

   hitListTemplatesInDocument = 2

End Enum

#Else

Public Const hitListTemplatesInListGalleries  As Long = 1

Public Const hitListTemplatesInDocument As Long = 2

#End If

______________ End of Global constants ________________

__________ Object ListFix from Stylist.dot ____________

Option Explicit

' $Version: 0.8.3

' $Author:  Steve Hudson, www.wordheretic.com

' $Short:   Fixes and utils for auto-lists

' 2do:      convert hard -> auto needs scope

'           check tabbing on indented styles

'           break into activedocument and listgallery listemplate treatments

'           cross convert multi-styled lists to single-styled

'           do a user-defined list template variable. to carry stuff in.

'$Customize:

Private Const defOneStyle As Boolean = True 'Not fully implemented yet

Private Const defListTemplateHome As Long = 2 'See Constants

'$Leave:

Private MyListStyles() As String

Private OneStyle As Boolean

Private LTHome As hitListTemplateLoc

'Private Bar As ProgressBar

Property Get ListTemplateHome() As hitListTemplateLoc

ListTemplateHome = LTHome

End Property

Property Let ListTemplateHome(Whereabouts As hitListTemplateLoc)

LTHome = Whereabouts

End Property

Property Get OneStylePerOutlineList() As Boolean

OneStylePerOutlineList = OneStyle

End Property

Property Let OneStylePerOutlineList(aFlag As Boolean)

OneStyle = aFlag

End Property

Private Sub Class_Initialize()

OneStyle = defOneStyle

LTHome = defListTemplateHome

'Set Bar = GetNewProgressBar

'$Customize:

ReDim MyListStyles(4) As String

MyListStyles(1) = "Body Text"

MyListStyles(2) = "List Bullet"

MyListStyles(3) = "List Number"

MyListStyles(4) = "List Number Outline"

End Sub

Public Sub ReportListStyles(Optional Scope As Document)

'$Author www.wordheretic.com

'$Short  Run this procedure first to make sure the styles in use for lists

'        are what they are supposed to be

Dim flStyleName As New Collection

Dim flStyleGallery As New Collection

Dim flListTemplate As New Collection

Dim flListLevel As New Collection

Dim ThisStyle As Long

GetListStyleNames flStyleName, flStyleGallery, flListTemplate, flListLevel,

Scope

Documents.Add

With Selection

   .InsertAfter "StyleName" & vbTab & "Gallery" & vbTab & "ListTemplate" &

vbTab & "Listlevel"

   .Style = wdStyleHeading4

   .InsertParagraphAfter

   .Collapse wdCollapseEnd

   For ThisStyle = 1 To flStyleName.Count

      If LTHome = hitListTemplatesInDocument Then

         .InsertAfter flStyleName(ThisStyle) & vbTab &

flStyleGallery(ThisStyle) & vbTab & flListTemplate(ThisStyle) & vbTab &

flListLevel(ThisStyle)

      Else

         .InsertAfter flStyleName(ThisStyle) & vbTab &

GalleryNum2Name(flStyleGallery(ThisStyle)) & vbTab &

flListTemplate(ThisStyle) & vbTab & flListLevel(ThisStyle)

      End If

      .InsertParagraphAfter

   Next

   ActiveDocument.Content.Select

   .ConvertToTable wdSeparateByTabs

End With

Set flStyleName = Nothing

Set flStyleGallery = Nothing

Set flListTemplate = Nothing

Set flListLevel = Nothing

End Sub

Public Sub FixStyledLists()

'$Author: www.wordheretic.com

'$Short: Run the style list reporter before running this to

'        ensure all your styles are set up correctly

'        Blows away restarts so needs a pre-check

'        or just use RestartListsAfterHeadings

Dim Para As Paragraph

Dim ListLevel As Long

Dim StyleNames As New Collection

Dim StyleGalleries As New Collection

Dim ListTemplates As New Collection

Dim ListLevels As New Collection

Dim Style As Variant

Dim pholder_Selection As Range

Dim RestartNumbering As Boolean

'Numerous problems.

'List style may not have a LT with the stylename in the linked list

'Does a list style have a LT attached

'Is a style with a listtemplate a list style?

Set pholder_Selection = Selection.Range

StyleNameCleanup

Application.ScreenUpdating = False

Options.Pagination = False

'All I want is style names here

GetListStyleNames StyleNames, StyleGalleries, ListTemplates, ListLevels,

ActiveDocument

Set StyleGalleries = Nothing

Set ListTemplates = Nothing

Set ListLevels = Nothing

'Bar.Caption = "Fixing Styled lists"

'Bar.Iterations = ActiveDocument.Paragraphs.Count

'Bar.Show

'reapply list style definitions

For Each Para In ActiveDocument.Paragraphs

   With Para

      If InCollection(Para.Style, StyleNames) Then 'its a list

         Restart = IsRestart(.Range.ListFormat)

         ListLevel = .Range.ListFormat.ListLevelNumber

         'Heres the real 'magic'

         'Just reapply the style. It has the correct list template stuff and

re-applying

         'it just forces Word to re-accept the correct list template!

         .Style = ActiveDocument.Styles(Para.Style)

         .Range.ListFormat.ListLevelNumber = ListLevel

         If Restart Then .Range.ListFormat.CanContinuePreviousList =

wdResetList

      Else

           'just in case there is some spurious list template attached

         'FRIGGIN KILL IT!!!

         .Range.ListFormat.RemoveNumbers

      End If

   End With

'   Bar.Update

Next

'Bar.Hide

Set StyleNames = Nothing

Set Para = Nothing

Application.ScreenUpdating = True

Options.Pagination = True

pholder_Selection.Select

ViewSelection

End Sub

Public Function IsRestart(aListFormat As ListFormat) As Boolean

'$Author: www.wordheretic.com

'$Short:  Why bother ignoring indented listlevels if you can fix their

'         restarting as well :-)

With aListFormat

   IsRestart = (.ListValue = 1) _

    And (.ListType = wdListSimpleNumbering _

    Or .ListType = wdListOutlineNumbering _

    Or .ListType = wdListMixedNumbering)

End With

End Function

Public Sub FixRestarts(Optional Scope As Range)

'$Author: www.wordheretic.com

'$Short:  This fixes lists that restart with some crazy number

'         but the rest of the list is fine.

Dim ListPara As Paragraph

If Scope Is Nothing Then Set Scope = ActiveDocument.Content

If Scope.ListParagraphs.Count > 1 Then

   For Each ListPara In Scope.ListParagraphs

      With ListPara.Range.ListFormat

         If .ListValue = 1 Then

            ListPara.Style = Scope.Parent.Styles(ListPara.Style)

            .ApplyListTemplate .ListTemplate, False

         End If

      End With

   Next

End If

End Sub

Private Sub GetListStyleNames(aName As Collection, aGallery As Collection, _

  aListTemplate As Collection, aListLevel As Collection, Optional Scope As

Document)

'$Author www.wordheretic.com

'$Short  Reports on the list templates available. Depending on what the

global property

'        LTHome is set to, the object responds with document based lists or

gallery based

'        lists.

Select Case LTHome

   Case hitListTemplatesInListGalleries

      Dim ListGallery As Long

      For ListGallery = 1 To 3 'bullets, numbers, outlines

          GetListStylesInListGallery ListGallery, aName, aGallery,

aListTemplate, aListLevel

      Next

   Case hitListTemplatesInDocument

      Dim LT As Long

      Dim LL As Long

      Dim StyleName As String

      If Scope Is Nothing Then Set Scope = ActiveDocument

      With Scope

         If .ListTemplates.Count > 0 Then

            For LT = 1 To .ListTemplates.Count

               With .ListTemplates(LT)

                  For LL = 1 To .ListLevels.Count

                     StyleName = .ListLevels(LL).LinkedStyle

                     If Len(StyleName) > 0 Then

                        aName.Add StyleName

                        aGallery.Add Scope.Name

                        aListTemplate.Add LT

                        aListLevel.Add LL

                     End If

                  Next

               End With 'LT

            Next

         End If 'no list templates

      End With 'ACTDOC

End Select

End Sub

Private Sub GetListStylesInListGallery(BNGallery As WdListGalleryType, aName

As Collection, aGallery As Collection, aListTemplate As Collection,

aListLevel As Collection)

'$Author www.wordheretic.com

'$Short  Tells what styles can be found in the lists hanging off the list

gallery

'        for those folk that excusively use the Word facade for setting up

lists.

Dim LT As Long

Dim LL As Long

Dim LinkedStyle As String

With ListGalleries(BNGallery)

   For LT = 1 To .ListTemplates.Count

      With .ListTemplates(LT)

         For LL = 1 To .ListLevels.Count

            LinkedStyle = .ListLevels(LL).LinkedStyle

            If Len(LinkedStyle) > 0 Then 'there is a linked style

               aName.Add LinkedStyle

               aGallery.Add BNGallery

               aListTemplate.Add LT

               aListLevel.Add LL

            End If

         Next

      End With

   Next

End With

End Sub

Private Function GalleryNum2Name(GalleryNumber As WdListGalleryType) As

String

'$Author www.wordheretic.com

'$Short  Stuff like this would have been my definition of user friendly

thanks MS

Select Case GalleryNumber

   Case wdBulletGallery

      GalleryNum2Name = "Bullet"

   Case wdNumberGallery

      GalleryNum2Name = "Number"

   Case wdOutlineNumberGallery

      GalleryNum2Name = "Outline"

End Select

End Function

Public Sub RestartListsAfterHeadings()

'$Author www.wordheretic.com

'$Short  This is it, the real McCoy. 99% of the time in the real world this

'        sucker solves all list-related problems. It can cause a fracturing

'        that then requires the complimentary FixRestarts to overcome.

Dim Para As Paragraph

Dim theListType As Long

Dim theListLevel As Long

Dim Names As New Collection

Dim RestartNext() As Boolean

Dim k As Long

Dim Index As Long

GetNumberedListStyleNames Names

Set Galleries = Nothing

Set ListTemplates = Nothing

Set ListLevels = Nothing

ReDim RestartNext(Names.Count) 'This holds our restart flags for each list

style

Application.ScreenUpdating = False

Options.Pagination = False

With ActiveDocument

'   Bar.Caption = "Restarting lists after headings"

'   Bar.Iterations = .Paragraphs.Count

'   Bar.Show

   For Each Para In .Paragraphs

      With Para

         If .OutlineLevel < wdOutlineLevelBodyText Then 'heading, so reset

restart flags

            For k = 1 To UBound(RestartNext)

               RestartNext(k) = True

            Next

         Else 'body text level

            Index = CollectionIndex(.Style, Names)

            If Index > 0 And RestartNext(Index) Then 'restart

               With .Range.ListFormat

                  If .ListTemplate Is Nothing Then Para.Style =

ActiveDocument.Styles(Para.Style)

                  theListLevel = .ListLevelNumber

                  .ApplyListTemplate .ListTemplate, False,

wdListApplyToWholeList

                  .ListLevelNumber = theListLevel

                  RestartNext(Index) = False

               End With

            End If 'restart

         End If 'heading level

      End With 'para

 '     Bar.Update

   Next Para

 '  Bar.Hide

   Application.ScreenUpdating = True

   Options.Pagination = True

   .Repaginate

End With

Set Names = Nothing

'ErrHandler:

'If Err.Number > 0 Then ' we have an error

'   If Err.Number = 5 Then

'      FixStyledLists

'      Resume

'   End If

'End If

End Sub

Public Sub ConvertHardCoded2Styles()

'$Author www.wordheretic.com

'$Short  Doesn't attempt to address outline numbered lists

'        but is still a treat to say the least. Turns hardcoded numbers

'        such as those produced by the convertnumberstotext method back into

'        OOOOOO - styled lists! You nominate the list names of course to

keep it simple

'        Easily extandable to many available options.

Const NumberStyle As String = "List Number"

Const BulletStyle As String = "List Bullet"

Dim CharPos As Long

Dim Para As Paragraph

Dim BulletChars As String

Dim FirstChar As String * 1

BulletChars = "." & "*" & "-" & Chr$(176) & ChrW$(61623) & ChrW$(61607) &

ChrW$(61608) & ChrW$(61609) & ChrW$(61610) & ChrW$(61528) & ChrW$(61529) &

ChrW$(61556) & ChrW$(61557) & ChrW$(61558) & ChrW$(61559) & ChrW$(61562) &

ChrW$(8224) & ChrW$(8225) & ChrW$(9679)

With ActiveDocument

'   Bar.Caption = "Converting hard-coded numbers to styles"

'   Bar.Iterations = .Paragraphs.Count

'   Bar.Show

   For Each Para In .Paragraphs

      With Para

         FirstChar = Left$(.Range.Text, 1)

         If StrConv(FirstChar, vbUnicode) = Format(Val(FirstChar)) Then

'number!

            .Style = NumberStyle

            StripStartOfPara Para

         ElseIf InStr(1, BulletChars, FirstChar) Then

            .Style = BulletStyle

            StripStartOfPara Para

         End If

      End With

'      Bar.Update

   Next Para

End With

'Bar.Hide

End Sub

Private Sub StripStartOfPara(aPara As Paragraph)

'$Author www.wordheretic.com

'$Short  Strips white space from a para start

'        This is how I ignore outline numbered lists

'        when converting hardcoded to auto

Dim FirstChar As String

Dim Safety As Long

Dim KeepGoing As Boolean

KeepGoing = True

With aPara.Range

   While Not iSAlpha(.Characters(1)) And KeepGoing

      Safety = .Characters.Count

      .Characters(1).Delete

      KeepGoing = (Safety <> .Characters.Count)

   Wend

End With

Set StringHandler = Nothing

End Sub

Public Sub ConvertAuto2HardCoded()

'$Author www.wordheretic.com

'$Short  Just for completeness

ActiveDocument.ConvertNumbersToText

End Sub

Public Sub ResetListGalleries()

'$Author www.wordheretic.com

'$Short  Resets all list gallery positions. Useful for when

'        lists are really screwed up.

Dim aListGallery As Long

For aListGallery = 1 To 3

    ResetListGallery aListGallery

Next aListGallery

End Sub

Private Sub ResetListGallery(BNGallery As WdListGalleryType)

'$Author www.wordheretic.com

'$Short  Resets all of a list gallery's positions

Dim aListTemplate As Long

Dim aListLevel As ListLevel

With ListGalleries(BNGallery)

   For aListTemplate = 1 To .ListTemplates.Count

      .Reset aListTemplate

      For Each aListLevel In .ListTemplates(aListTemplate).ListLevels

         aListLevel.LinkedStyle = ""

      Next

   Next

End With

End Sub

Public Sub RestartListNumbering(Optional aRange As Variant)

'$Author www.wordheretic.com

'$Short  Resets a list's numbering EVERY time, unlike Word's facade

If aRange Is Nothing Then Set aRange = Selection.Range

aRange.Collapse

On Error Resume Next

With aRange.ListFormat

   .ApplyListTemplate .ListTemplate, False

End With

End Sub

Public Sub ShowUsedListTemplates()

'$Author www.wordheretic.com

'$Short  Run this on a COPY of your document to see how

'        badly mangled the lists are

Dim Index As Long

On Error Resume Next

With ActiveDocument

   If .ListTemplates.Count > 0 Then

      For Index = 1 To .ListTemplates.Count

         With .ListTemplates(Index)

            If Len(.Name) = 0 Then .Name = Format(Index)

         End With

      Next

'      Bar.Caption = "Adding list debug information"

'      Bar.Iterations = .ListParagraphs.Count

'      Bar.Show

      For Index = 1 To .ListParagraphs.Count

         With .ListParagraphs(Index).Range

            .InsertBefore "[" & .ListFormat.ListTemplate.Name & "]"

         End With

'         Bar.Update

      Next Index

'      Bar.Hide

   End If ' no list templates

End With

End Sub

Public Sub CoalesceListStyles()

'$Author www.wordheretic.com

'$Short  Turns List Number 1, List Number 2, List Number 3...,

'        into an outline numbered List Number style using just List Number

'        Does this using all the hard-coded list styles below

Dim ListStyle As Long

Dim Para As Paragraph

Dim StyleLevel As Long

'Bar.Caption = "Coalescing list styles"

'Bar.Iterations = ActiveDocument.Paragraphs.Count

'Bar.Show

For Each Para In ActiveDocument.Paragraphs

   For ListStyle = 1 To UBound(MyListStyles)

      If InStr(1, Para.Style, MyListStyles(ListStyle), vbTextCompare) And _

       Len(Para.Style) = Len(MyListStyles(ListStyle)) + 2 Then 'we have a

convert

         StyleLevel = Val(Right$(Para.Style, 1))

         Para.Style = MyListStyles(ListStyle)

         While StyleLevel > 1

            StyleLevel = StyleLevel - 1

            Para.Indent

         Wend

         Exit For

      End If

   Next ListStyle

'   Bar.Update

Next Para

'Bar.Hide

End Sub

Public Sub StripSeqFieldsInListStyles(Optional Scope As Range)

Dim iField As Long

Dim iStyle As Long

Dim FieldStyle As String

If Scope Is Nothing Then Scope = ActiveDocument.Content

With Scope

   For iField = .Fields.Count To 1 Step -1

      If .Fields(iField).Type = wdFieldSequence Then 'check for a forbidden

style

         FieldStyle = .Fields(iField).Result.Style

         For iStyle = 1 To UBound(MyListStyles)

            If MyListStyles(iStyle) = FieldStyle Then

               .Fields(iField).Delete

               Exit For

            End If

         Next

      End If

   Next

End With

Set Scope = Nothing

End Sub

Public Function CopyDocListTemplatesInUse(InDoc As Document, OutDoc As

Document)

'$Teaser  Read indoc for all styles in list templates

'         if style not present in doc dont copy it

End Function

Private Sub Class_Terminate()

'Set Bar = Nothing

End Sub

___________________ End object ________________________

___________ Start Style Gallery Extract _______________

Public Sub StyleNameCleanup()

'$Author www.wordheretic.com

'$Short  removes the suffixes that stylenames can acquire

Dim aStyle As Style

Dim StartOfSuffix As Long

Dim OldName As String

Dim NewName As String

Dim Finder As Range

Const Gen As String = "Generic"

On Error Resume Next

aDoc.Styles.Add Gen, wdStyleTypeParagraph

On Error GoTo 0

For Each aStyle In aDoc.Styles

   With aStyle

      StartOfSuffix = InStr(1, .NameLocal, ",")

      If StartOfSuffix > 0 Then

         OldName = .NameLocal

         NewName = Left$(.NameLocal, StartOfSuffix - 1)

         'find and replace stylenames

         Set Finder = ActiveDocument.StoryRanges(wdMainTextStory)

         With Finder.Find

            .Style = OldName

            .Replacement.Style = Gen

            .Execute Replace:=wdReplaceAll

         End With

         .NameLocal = NewName

         With Finder.Find

            .Style = Gen

            .Replacement.Style = NewName

            .Execute Replace:=wdReplaceAll

         End With

      End If

   End With

Next

Set aStyle = Nothing

End Sub

________________ End Style Gallery Extract _________________________

_________________ Start Collector Extract __________________________

Public Function CollectionIndex(ByVal Needle As String, ByVal Haystack As

Collection) As Long

'$Author www.wordheretic.com

'$Short  Not all collections allow you to access the index by name.

If Haystack Is Nothing Then Exit Function

If Haystack.Count = 0 Then Exit Function

Dim Straw As Long

For Straw = 1 To Haystack.Count

   If Needle = Haystack(Straw) Then

      CollectionIndex = Straw

      Exit For

   End If

Next

End Function

Public Function InCollection(Needle As String, Haystack As Collection) As

Boolean

'$Author www.wordheretic.com

'$Short  Well, do we have a Needle in our Haystack or not?

'$2do    replace this with CollectionIndex

Dim Straw As Variant

If Not (Haystack Is Nothing) Then

   If Haystack.Count > 0 Then

      For Each Straw In Haystack

         If Straw = Needle Then

            InCollection = True

            Exit For

         End If

      Next

   End If

End If

Set Straw = Nothing

End Function

__________________ End Collector Extract ___________________________

_______________ Misc Extracts _________________

Public Function IsAlpha(SomeText As String, Optional OtherLegalChars As

String = " ") As Boolean

'Allows only the alphanumeric and other defined legal characters

'Defaults to also allowing spaces.

Dim Index As Integer

Dim s As String * 1

For Index = 1 To Len(SomeText)

   IsAlpha = False

   s = Mid$(SomeText, Index, 1)

   IsAlpha = IsCharAlphaNumeric(s)

   If Not IsAlpha Then IsAlpha = (InStr(1, OtherLegalChars, s) > 0)

   If Not IsAlpha Then Exit For

Next

Private Declare Function IsCharAlphaNumericA Lib "USER32" _

 (ByVal aCharacter As Byte) As Long

Public Function IsCharAlphaNumeric(aCharacter As String) As Boolean

IsCharAlphaNumeric = CBool(IsCharAlphaNumericA(Asc(aCharacter)))

End Function

_______________ Misc Extracts _________________

Steve Hudson

Word Heretic, Sydney, Australia

Tricky stuff with Word or words for you.

Email:      steve@xxxxxxxxxxxxxxx

Products:   http://www.geocities.com/word_heretic/products.html

Spellbooks: 728 pages of dump left and dropping...

-----Original Message-----

From: austechwriter-bounce@xxxxxxxxxxxxx

[mailto:austechwriter-bounce@xxxxxxxxxxxxx]On Behalf Of Kobus Myburgh

Sent: Monday, 22 September 2003 6:07 PM

To: austechwriter@xxxxxxxxxxxxx

Subject: atw: Word Numbering Issues! Save my life, please!

Hi!

My boss gave me the task to figure out why the numbering in our

templates are not working properly, especially the restart numbering.

When you restart the numbering, save and close the document, re-open it,

the restarted numbering doesn't work as it is supposed to - causing the

whole document to be totally messed up.

After spending literally HOURS with Word in spying through our macros,

unable to find anything wrong with them, I turned to the Internet for

help, and found you.

In the article I found [1] via Google, you mentioned that you have a

macro to address this problem. How much does it cost? Where can I get

it? What do you need from me? Please contact me a.s.a.p. as I am

desperate for a solution. Do I have to send you our template for you to

build it in? Or what do we do?

**************************************************

To post a message to austechwriter, send the message to 

austechwriter@xxxxxxxxxxxxxx

To subscribe to austechwriter, send a message to 

austechwriter-request@xxxxxxxxxxxxx with "subscribe" in the Subject field.

To unsubscribe, send a message to austechwriter-request@xxxxxxxxxxxxx with 

"unsubscribe" in the Subject field.

To search the austechwriter archives, go to 

www.freelists.org/archives/austechwriter

To contact the list administrator, send a message to 

austechwriter-admins@xxxxxxxxxxxxx

**************************************************

• References:

  • atw: Word Numbering Issues! Save my life, please!

    • From: Kobus Myburgh

Other related posts:

• » atw: Re: Word Numbering Issues! Save my life, please!

• » atw: Re: Word Numbering Issues! Save my life, please!

• » atw: Re: Word Numbering Issues! Save my life, please!

• » atw: Re: Word Numbering Issues! Save my life, please!

• » atw: Re: Word Numbering Issues! Save my life, please!

• » atw: Re: Word Numbering Issues! Save my life, please!

• » atw: Re: Word Numbering Issues! Save my life, please!