בקשה | תוכן ענינים לפי כותרות

[u88]

יש לי מסמך עם כמה סימנים (כותרת 1) ובכל סימן כמה סעיפים (כותרת 2) ובכל סעיף כמה נושאים (כותרת 3)
ואני רוצה לעשות תוכן מותאם אישית שכל הסעיפים קטנים שהם כותרת 3 יהיו בתוכן מיוחד אחרי תחילת הסעיף

לדוגמא
סימן א'
סעיף א'
בענין ....
קושיא....
תירוץ....
יסוד....
העולה מן האמור ....

סעיף ב'

וכו'
אשמח אם משהו יכול להפנות אותי לפקודת מאקרו שתעשה את זה בצורה טובה אודה לו מאוד

[יאיר הבהיר]

@u88 משהו כמו זה?

[u88]

@יאיר-הבהיר לא
כוונתי שתוך כדי המסמך כל כותרת 2 יופיע אחריה תוכן ענינים קטן שהוא מסכם את הסעיפים הבאים

[אביעד]

אתה מתכוון לדבר כזה? (תוכן עניינים אפשר לעשות בשניות אח"כ)

[u88]

@אביעד
את זה אני יודע ב"ה. אני מתכוון לזה
רק שהמקרו ישלוף כל פעם את הכותרות 3 בין כותרת 2 לכותרת 2

[975]

@u88
תבדוק אם זה עוזר לך

Sub CopyHeading3AfterHeading2()
    Dim doc As Document
    Dim r As Range
    Dim para As Paragraph
    Dim h2Range As Range
    Dim h3Text As String
    Dim i As Integer
    
    Set doc = ActiveDocument
    
    For i = doc.Paragraphs.Count To 1 Step -1
        Set para = doc.Paragraphs(i)
        

        If para.Style = doc.Styles(wdStyleHeading2) Then
            Set h2Range = para.Range
            h3Text = ""
            
            Dim j As Integer
            For j = i + 1 To doc.Paragraphs.Count
                Dim nextPara As Paragraph
                Set nextPara = doc.Paragraphs(j)
                
                If nextPara.Style = doc.Styles(wdStyleHeading2) Or _
                   nextPara.Style = doc.Styles(wdStyleHeading1) Then
                    Exit For
                End If
                
                If nextPara.Style = doc.Styles(wdStyleHeading3) Then
                    h3Text = h3Text & Replace(nextPara.Range.Text, vbCr, "") & " | "
                End If
            Next j
            
            If h3Text <> "" Then

                h3Text = Left(h3Text, Len(h3Text) - 3)
                
                Dim newRange As Range
                Set newRange = doc.Range(h2Range.End, h2Range.End)
                newRange.InsertAfter vbCr & "בפרק זה: " & h3Text & vbCr
                
                newRange.Font.Italic = True
                newRange.Font.Size = 10
            End If
        End If
    Next i
    
    MsgBox "הפעולה הושלמה!.", vbInformation
End Sub

[u88]

@975 אם יורשה לי לשאול מה זה עושה