VBA code to convert Heading 1, 2, 3 etc. numbering

Lady_Laughsalot · #1 04-16-2018, 05:41 AM

Hi, I am trying to write code to firstly convert auto numbering to manual then convert the Heading 1, 2, 3 numbering to Schedule Level numbering. I've got the code to work but at the moment it is converting all auto numbering to manual. How can I get the first bit of the code to only convert the Heading 1, 2 numbering to manual and leave everything else as it is. The code works to insert Schedule Level numbering as auto but it leaves in the manual number after the auto numbering - is there a way I can remove the manual number also. If you run the code on the attached document you will see what I mean.

Many thanks in advance of help. Shelley

Code:

Sub DPU_ConvertToScheduleNum()
   ActiveDocument.Range.ListFormat.ConvertNumbersToText
    Selection.Find.Style = ActiveDocument.Styles("Heading 1")
      Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Schedule Level 1")
    With Selection.Find
        .Text = "[0-9.]@^t"
        .Replacement.Text = ""
           End With
    Selection.Find.Execute Replace:=wdReplaceAll
      Selection.Find.Style = ActiveDocument.Styles("Heading 2")
      Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Schedule Level 2")
    With Selection.Find
        .Text = "[0-9.0-9]@^t"
        .Replacement.Text = ""
         End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Style = ActiveDocument.Styles("Heading 3")
      Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Schedule Level 3")
    With Selection.Find
        .Text = "[0-9.0-9.0-9]@^t"
        .Replacement.Text = ""
         End With
    Selection.Find.Execute Replace:=wdReplaceAll
   Selection.Find.Style = ActiveDocument.Styles("Heading 4")
      Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Schedule Level 4")
    With Selection.Find
        .Text = "[0-9.0-9.0-9.0-9.0-9]@^t"
        .Replacement.Text = ""
         End With
    Selection.Find.Execute Replace:=wdReplaceAll
    Selection.Find.Style = ActiveDocument.Styles("Heading 5")
      Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Schedule Level 5")
    With Selection.Find
        .Text = "[\(][a-z][\)]^t"
        .Replacement.Text = ""
         End With
    Selection.Find.Execute Replace:=wdReplaceAll
         Selection.Find.Style = ActiveDocument.Styles("Heading 6")
      Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Schedule Level 6")
    With Selection.Find
        .Text = "[\(][a-z][\)]^t"
        .Replacement.Text = ""
         End With
    Selection.Find.Execute Replace:=wdReplaceAll
     Selection.Find.Style = ActiveDocument.Styles("Heading 7")
      Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "Schedule Level 7")
    With Selection.Find
        .Text = "[\(][A-Z][\)]^t"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
     End With
   Selection.Find.Execute Replace:=wdReplaceAll
 
End Sub

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Heading not following the correct numbering	jongleur	Word	2	05-16-2017 10:52 AM
Fixing my heading numbering	tomsrv	Word	3	08-31-2016 12:17 AM
Unhidden Heading Numbering	snmuvz	Word	5	02-04-2015 08:01 PM
Heading 3 numbering not working right	Dr Wu	Word	2	04-02-2013 07:24 AM
Heading numbering anomaly	Ulodesk	Word	8	03-19-2012 01:57 PM