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.

[margaret16]

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




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

[Aussiebear]

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.

[macropod]

That code is pretty awful. Try:

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.