Sample.docx

Hi everyone, I really need a help on that.

The first picture is the original source file with all the numbering and style formatting.

IMG_2018.jpgSample.docx

Ultimately, I would like to copy all the heading number to corresponding paragraph as below.


IMG_2017.jpg

I did some research and found some related code. And finally successfully adding some pre-set text at the beginning of the paraph with "Normal" Style, however , the second paragraph of that section would not be able to add. I don't know why. which show as below

IMG_2019.jpg

After that I find another code which show the corresponding level of that para with msg box.

IMG_2020.jpg

Can you someone can help to merge these function together...



Sub ApplyMultiLevelHeadingNumbers()
Selection.Range.ListFormat.ConvertNumbersToText
End Sub


Sub Demo()
Application.ScreenUpdating = False
Dim Par As Paragraph, Rng As Range
For Each Par In ActiveDocument.Paragraphs
  If Par.Style = "Normal" Then
    If Rng Is Nothing Then
      Set Rng = Par.Range
    Else
      Rng.End = Par.Range.End
    End If
  Else
    Call RngFmt(Rng)
  End If
  If Par.Range.End = ActiveDocument.Range.End Then
    Call RngFmt(Rng)
  End If
Next
Application.ScreenUpdating = True
End Sub


Sub RngFmt(Rng As Range)
If Not Rng Is Nothing Then
  With Rng
    .End = .End - 1
    .InsertBefore "(Sample) "
   Set Rng = Nothing
  End With


End If
End Sub




Public Sub FindPreviousOutlineLevel()
Dim aNumber As Long
Dim aRange As Word.Range


Set aRange = ActiveDocument.Range(0, Selection.Range.End)
For aNumber = aRange.Paragraphs.Count To 1 Step -1
If ActiveDocument.Paragraphs(aNumber).Range.ParagraphFormat.OutlineLevel _
<> 10 Then
Set aRange = ActiveDocument.Paragraphs(aNumber).Range
With aRange.Find
.MatchWildcards = True
.Text = "<[0-9.-]{1,}"
.Execute
If .Found Then
MsgBox aRange


Else
MsgBox "No Number Found Here: " & aRange
End If
End With
Exit For
End If
Next aNumber
End Sub