Copy previous heading number of "Heading " to the paragraph in "Normal "style

Attachment 29485

Hi everyone, I really need a help on that.

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

Attachment 29484Attachment 29485

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


Attachment 29483

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

Attachment 29482

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

Attachment 29486

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

Code:

---

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

---

If I understand correctly, the following will do what you require, at least with your sample document.
If you want the strings added before any existing text between the heading sections then remove the two optional lines.

Code:

---

Sub Macro1()
Dim oPara As Paragraph
Dim oRng As Range
Dim lPara As Long
Dim sHead As String
Const sList As String = "0123456789.)"
    For lPara = ActiveDocument.Paragraphs.Count To 1 Step -1
        Set oPara = ActiveDocument.Paragraphs(lPara)
        If oPara.Style Like "Heading ?" Then
            If Not Right(oPara.Style, 1) = sHead Then
                sHead = Right(oPara.Style, 1)
                If lPara = ActiveDocument.Paragraphs.Count Then 'optional
                    oPara.Range.InsertParagraphAfter
                End If  'optional
                Set oRng = oPara.Range.Next.Paragraphs(1).Range
                oRng.Text = oPara.Range.Text
                oRng.Style = "Normal"
                oRng.Collapse 1
                oRng.InsertBefore "("
                oRng.MoveEndWhile sList
                oRng.InsertAfter ")"
            End If
        End If
    Next lPara
lbl_Exit:
    Set oPara = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

Thank you for your reply The direction is right, however the outcome is not what exactly I want .<br>
When I used your code above, it directly replace the content with the heading. <br>
What I looking for is that the content remind unchanged, and only adding the numbering of heading at the begining of the corresponding paragraph.<br>
(Like what I highlight in the final output below) Attachment 29488

Ah! OK that needs a slightly different approach. I have included the highlight, to demonstrate it works, but that is easily removed, by removing the indicated line.

Code:

---

Sub Macro1()
Dim oPara As Paragraph
Dim oRng As Range
Dim lPara As Long
Dim sHead As String

    For lPara = 1 To ActiveDocument.Paragraphs.Count
        Set oPara = ActiveDocument.Paragraphs(lPara)
        If oPara.Style Like "Heading ?" Then
            sHead = Split(oPara.Range.Text, Chr(9))(0)
            sHead = "(" & sHead & ") "
        ElseIf oPara.Style = "Normal" Then
            Set oRng = oPara.Range
            If Len(oRng) > 1 Then
                oRng.Collapse 1
                oRng.Text = sHead
                oRng.HighlightColorIndex = wdYellow    'to illustrate
            End If
        End If
    Next lPara
lbl_Exit:
    Set oPara = Nothing
    Set oRng = Nothing
    Exit Sub
End Sub

---

It does work!! Thank you so much !! Ask one more question here.

What if , I want this function apply to my selection only but not the whole document.?

Change the two instances of 'ActiveDocument' to 'Selection'