Copy Content from One Word Doc to Another

[JonXL]

Hi,

I'm trying to append the contents from one Word file to another. Here is more or less what I'm doing now.

Sub AppendDocument()
    Dim wdDoc As Document, wdOutputDoc As Document
    
    Set wdDoc = Documents.Add
    Set wdDoc = Documents.Add
    
    With wdDoc
    
        Do
              
            'do some stuff to this document
            
            .Content.Copy
            
            With wdOutputDoc.Content
                .Collapse direction:=wdCollapseEnd
                .InsertBreak wdPageBreak
                .PasteAndFormat wdFormatOriginalFormatting
            End With
        
        Loop
    
    End With

End Sub

This works... except because it uses the clipboard, it's open to get junk in it if someone copies between the copy and paste commands of this code. (I tested this while it was running by rapidly and repeatedly copying 'blah' to the clipboard and in at least one instance the appended content was 'blah' and not the contents of the document I wanted appended.)

When I try by using like this ...

            With wdOutputDoc.Content
                .Collapse direction:=wdCollapseEnd
                .InsertBreak wdPageBreak
                .InsertAfter wdDoc.Content
            End With

... it doesn't include the headings, etc.

I've looked into InsertFile but as you can see from the code, both documents are created in the code and never saved, so there isn't a file location to use. If watching the screen while it runs, you see variably Document1, Document2 or Document3, Document6, etc. - they are not saved files. But maybe there's a way with InsertFile even though they aren't saved.

Otherwise, I'm not sure what options there are for this to work.

Thank you,
Jon

 

[Macropod]

Pretty basic, really:

Sub AppendDocument()
Dim DocSrc As Document, DocTgt As Document
Set DocSrc = ActiveDocument
Set DocTgt = Documents.Add
'Do whatever pre-processing you want, then:
DocTgt.Range.Characters.Last.FormattedText = DocSrc.Range.FormattedText
End Sub

 

[JonXL]

Thank you. Unfortunately that doesn't bring over the headings. This is what I have:

Sub AppendDocument()
    wdOutputDoc As Document
  
    Set wdOutputDoc = Documents.Add

    wdOutputDoc.Range.Characters.Last.FormattedText = ThisDocument.Range.FormattedText

End Sub

Unlike the copy-paste commands, this doesn't bring over all the content from the document. It's only bringing over the body text and not the headings, text boxes, etc.

 

[Macropod]

On the contrary, it brings over exactly the same content a copy/paste would, including headings and textboxes. Perhaps the problem is that you're using 'ThisDocument' instead of 'ActiveDocument'. If you want to replicate hears and footers, you need to use the same method on those, too.

See, more fully: Combine Multiple Word Documents (msofficeforums.com)

 

[JonXL]

Perhaps the problem is that you're using 'ThisDocument' instead of 'ActiveDocument'.

That didn't seem to make a difference.

If you want to replicate hears and footers, you need to use the same method on those, too.

Do you mean I'd have to have that for each of the document's ranges?

See, more fully: Combine Multiple Word Documents (msofficeforums.com)

Thank you for that link. With some tweaking to reference the currently opened files that does what I need it to do (the first sub with my changes, need a little more cleanup as this was just for testing):

Sub CombineDocuments()
Application.ScreenUpdating = True
Dim strFolder As String, strFile As String, strTgt As String
Dim wdDocTgt As Document, wdDocSrc As Document, HdFt As HeaderFooter
'strFolder = GetFolder: If strFolder = "" Then Exit Sub
Set wdDocTgt = Documents.Add 'ActiveDocument: strTgt = ActiveDocument.FullName
strFile = Dir(strFolder & "\*.doc", vbNormal)
'While strFile <> ""
  If 1 = 1 Then 'strFolder & strFile <> strTgt Then
    Set wdDocSrc = ThisDocument 'Documents.Open(FileName:=strFolder & "\" & strFile, AddToRecentFiles:=False, Visible:=False)
    With wdDocTgt
      .Characters.Last.InsertBefore vbCr
      .Characters.Last.InsertBreak (wdSectionBreakNextPage)
      With .Sections.Last
        For Each HdFt In .Headers
          With HdFt
            .LinkToPrevious = False
            .Range.Text = vbNullString
            .PageNumbers.RestartNumberingAtSection = True
            .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber
          End With
        Next
        For Each HdFt In .Footers
          With HdFt
            .LinkToPrevious = False
            .Range.Text = vbNullString
            .PageNumbers.RestartNumberingAtSection = True
            .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber
          End With
        Next
      End With
      Call LayoutTransfer(wdDocTgt, wdDocSrc)
      .Range.Characters.Last.FormattedText = wdDocSrc.Range.FormattedText
      With .Sections.Last
        For Each HdFt In .Headers
          With HdFt
            .Range.FormattedText = wdDocSrc.Sections.Last.Headers(.Index).Range.FormattedText
            .Range.Characters.Last.Delete
          End With
        Next
        For Each HdFt In .Footers
          With HdFt
            .Range.FormattedText = wdDocSrc.Sections.Last.Footers(.Index).Range.FormattedText
            .Range.Characters.Last.Delete
          End With
        Next
      End With
    End With
    'wdDocSrc.Close SaveChanges:=False
  End If
  'strFile = Dir()
'Wend
With wdDocTgt
  ' Save & close the combined document
  '.SaveAs FileName:=strFolder & "Forms.docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
  ' and/or:
  '.SaveAs FileName:=strFolder & "Forms.pdf", FileFormat:=wdFormatPDF, AddToRecentFiles:=False
  '.Close SaveChanges:=False
End With
Set wdDocSrc = Nothing: Set wdDocTgt = Nothing
Application.ScreenUpdating = True
End Sub

I wish there were a way to do this in one go like copy-paste, though. This runs in a little under a second which could add up quick with a lot of documents.

 

[Macropod]

Do you mean I'd have to have that for each of the document's ranges?

Indeed I do.

I wish there were a way to do this in one go like copy-paste, though. This runs in a little under a second which could add up quick with a lot of documents.

Except for the clipboard, copy/paste doesn't work any differently.

You've omitted the LayoutTransfer Sub from the link I gave you. IF all the documents have the same page layout, you could omit both that sub and the line:

Call LayoutTransfer(wdDocTgt, wdDocSrc)

You could possibly also delete the two instances of:

            .PageNumbers.RestartNumberingAtSection = True
            .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber

These measures would help the code run more quickly.

Still, complaining that the code "runs in a little under a second" for each document seems churlish given the time it saves over doing the same thing manually.

 

[JonXL]

Except for the clipboard, copy/paste doesn't work any differently.

The issue with that approach is that the time between the copy and the paste leaves room for the users to put something else into the clipboard which then gets pasted instead of the contents of the document.

You've omitted the LayoutTransfer Sub from the link I gave you.

I have it in the code I ran - I just posted the parts that I tweaked; I left LayoutTransfer as it was.

IF all the documents have the same page layout, you could omit both that sub and the line:

Call LayoutTransfer(wdDocTgt, wdDocSrc)

You could possibly also delete the two instances of:

            .PageNumbers.RestartNumberingAtSection = True
            .PageNumbers.StartingNumber = wdDocSrc.Sections.First.Headers(HdFt.Index).PageNumbers.StartingNumber

These measures would help the code run more quickly.

We're a little over half a second, now. I'll keep playing with it and see what else can be done. I imagine I'd have to transfer the layout in the first loop, though, right? After that, they will have the same layout and then I would skip that...?

Still, complaining that the code "runs in a little under a second" for each document seems churlish given the time it saves over doing the same thing manually.

Absolutely! But if working with thousands of documents, every second adds up big in the end, so I'm looking for the quickest way to run this.

My original setup was making and saving the document over and over again from a template and then combining them. The code you've provided is without a doubt a significant improvement the way it is, so I certainly appreciate you bringing that here. I'm not attempting to be ungrateful at all.

Thank you.

 

[Macropod]

Well, the code In the link I posted automates the combining of a whole folder of documents. You've clobbered all of that, meaning you'll still have to do them one at a time. Not an improvement, methinks.

 

[JonXL]

Well, the code In the link I posted automates the combining of a whole folder of documents. You've clobbered all of that, meaning you'll still have to do them one at a time. Not an improvement, methinks.

Not sure what's been clobbered. I used the code (with modifications to fit my circumstances) and it is correctly appending from one document onto the next. There is no "one at a time" as everything is done in the code without the user being involved.

I think it works well. And I genuinely appreciate the code since the alternative wasn't workable.

Thank you.

 

[Satheesh9012]

Hi Team,

I need a help with something similar, it would be very helpful if you guys could help me with it, i have stored a few word documents in a specific folder(Received word requestor), i need to copy all the word contents from the received word document to a standard template and also should save the new file as HTML format with specific naming convention, the code should run in all the word document updated in that specific folder, without loosing any alignment or spacing changes in word standard template.

Please help

Thanks
Satheesh,