How to Insert Section from Source Doc into Target Doc

[iwritedoc62]

Hello all,

I am looking for help inserting a full section from a source doc into a target document.

For example:

"3. SECTION HEADING EXAMPLE
3.1 Text here
3.2 Text here
3.3 Text here
Table here:

Table Heading	Text
Text	Text
Image	Image

3.4 Text here"

I need the section from the source document to be pasted into a specific area in the target document, for example, between "2. SECTION HEADING EXAMPLE" and "4. SECTION HEADING EXAMPLE"

I know this is possible because I used a code that did this previously but I cannot find it. I have a code that this sub will be inserted into that loops through all documents in a folder and performs a subroutine -- it will open all documents in a folder, perform the action, and close the document. All the documents need this specific section added between existing Section X and Y.

Thank you for any help you can provide!

[Aussiebear]

Welcome to VBAX iwritedoc62. Until one of the word guru's drops by, perhaps this will get you started in the right direction

Sub InsertAfterMethod()
  Dim MyText As String
  Dim MyRange As Object
  Set MyRange = ActiveDocument.Range
  MyText = "<Replace this with your text>"
  ' Selection Example:
  Selection.InsertAfter (MyText)
  ' Range Example:
  ' (Inserts text at the current position of the insertion point.)
  MyRange.Collapse
  MyRange.InsertAfter (MyText)
End Sub

Yes, it doesn't loop through your documents, but if you wish to test it and see if it can be modified.

[ernsersaig]

Here's a VBA code that should accomplish this:

VB.Net
Sub InsertSection()

    Dim srcDoc As Document
    Dim tgtDoc As Document
    Dim srcRng As Range
    Dim tgtRng As Range
    Dim shp As Shape

    Const srcHeading As String = "3. SECTION HEADING EXAMPLE"
    Const tgtHeading As String = "2. SECTION HEADING EXAMPLE"

    For Each srcDoc In ActiveDocument.Parent.Documents
        srcDoc.Activate

        ' Find the source section based on the heading
        Set srcRng = srcDoc.Sections(1).Range
        While srcRng.Find.Execute(srcHeading)
            Set srcRng = srcRng.Find.Found
            Exit While
        End While

        ' Copy the entire section
        srcRng.Copy

        ' Find the target section in the target document
        Set tgtDoc = ActiveDocument
        Set tgtRng = tgtDoc.Sections(1).Range
        While tgtRng.Find.Execute(tgtHeading)
            Set tgtRng = tgtRng.Find.Found
            Exit While
        End While

        ' Paste the copied section after the target heading
        tgtRng.Collapse wdCollapseEnd
        tgtRng.Paste

        ' Copy any shapes within the section
        For Each shp In srcDoc.Shapes
            If shp.Range.Start >= srcRng.Start And shp.Range.End <= srcRng.End Then
                shp.Copy
                tgtDoc.Shapes.Paste
            End If
        Next shp

    Next srcDoc

End Sub

[arnelgp]

bro, the post was made 4 months ago..

[Aussiebear]

bro, the post was made 4 months ago..

Welcome to VBAX ernsersaig. Thank you for your contribution. Pay no attention to arnelgp's post.