How to Insert Section from Source Doc into Target Doc

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!

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

Code:

---

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.

Here's a VBA code that should accomplish this:

Code:

---

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

---

bro, the post was made 4 months ago..

Quote:

---

Originally Posted by arnelgp

bro, the post was made 4 months ago..

---

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

Quote:

---

Originally Posted by ernsersaig

Here's a VBA code that should accomplish this:

Code:

---

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

---

---

I entered your code but the system still reports an error, why?

Quote:

---

Originally Posted by margaret16

I entered your code but the system still reports an error, why?

---

Simply because the system was designed to report the error. If you were asking about a particular error in the code supplied, then it would be more helpful, if you indicated the actual error being shown.

That code is pretty awful. Try:

Code:

---

Sub XferHeadingRange()Application.ScreenUpdating = False
Dim DocSrc As Document, RngSrc As Range
Dim DocTgt As Document, RngTgt As Range
Set DocTgt = ActiveDocument
With Application.Dialogs(wdDialogFileOpen)
  If .Show = -1 Then
    .AddToMru = False
    .ReadOnly = True
    .Visible = False
    .Update
    Set DocSrc = ActiveDocument
  End If
End With
If DocSrc Is Nothing Then Exit Sub
With DocSrc.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "SOURCE SECTION HEADING EXAMPLE"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = False
    .Execute
  End With
  If .Find.Found = True Then
    Set RngSrc = .Paragraphs(1).Range
    Set RngSrc = RngSrc.GoTo(What:=wdGoToBookmark, Name:="\HeadingLevel")
  Else
    MsgBox "Source Content Not Found!", vbExclamation
    GoTo CleanUp
  End If
End With
With DocTgt.Range
  With .Find
    .ClearFormatting
    .Replacement.ClearFormatting
    .Text = "TARGET SECTION HEADING EXAMPLE"
    .Replacement.Text = ""
    .Forward = True
    .Wrap = wdFindStop
    .MatchWildcards = False
    .Execute
  End With
  If .Find.Found = True Then
    Set RngTgt = .Paragraphs(1).Range
    RngTgt.Collapse wdCollapseStart
    RngTgt.FormattedText = RngSrc.FormattedText
  Else
    MsgBox "Destination Not Found!", vbExclamation
  End If
End With
: CleanUp
DocSrc.Close SaveChanges:=False
Set RngSrc = Nothing: Set DocSrc = Nothing
Set RngTgt = Nothing: Set DocTgt = Nothing
Application.ScreenUpdating = True
End Sub

---

Note: The code assumes the target document is already open and that Word's Heading Styles are used in the source document to denote the various ranges. When running the macro, you select the source document to open from the dialog box. For the target document, the heading to specify is the one after the location where you want the source content inserted.