VBA Copying from Word file to Word file

[Mumba]

Hi All

I am working on a macro that is able to, copy entire word files into one master word file based on selections ("x" markings) made in a excel sheet.
I got the part down with opening files and also part of the copying. My main issue is that the macro keeps overwriting the previous paste.

Sub CreateAgreement()

Set objWord = CreateObject("Word.Application")
docpath = "K:\Supply Chain\Quality Support\Agreements\EN\QMF-071_01 Framework agreement template.docx"
Set wDoc = objWord.documents.Open(docpath)
objWord.Visible = True

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Selection")
lr = ws.Cells(100, "G").End(xlUp).Row
sr = 3

For i = sr To lr
    If ws.Cells(i, "B") <> "" Then
        docpath = ws.Cells(i, "H")
        
        Rangeend = wDoc.Content.End - 1
        wDoc.Content.InsertAfter Rangeend
        Set WdCopyFrom = objWord.documents.Open(docpath)
            WdCopyFrom.Activate
              WdCopyFrom.Range.Copy
        
        wDoc.Activate
        wDoc.Range.Paste
        'wDoc.Content.InsertParagraphAfter
    End If
Next
End Sub

 

[NdNoviceHlp]

Hi Mumba. Here's a general outline for 2 methods. Method 1 transfers the doc as a string. Method 2 uses copy and paste. Method 1 is recommended unless there's content other than text. If U do use Method 2 expect that your clipboard will likely crash and error unless U add some code to manage it as well. Comment/uncomment the Method as needed. HTH. Dave

Option Explicit
Private Sub test()
Dim MyRange As Variant, docpath As String, docpath2 As String, objword As Object
Dim BigStr As String, MyRange2 As Variant

docpath = "D:\testfolder\data.doc"
docpath2 = "D:\testfolder\transfer.doc"

On Error GoTo ErFix
Set objword = CreateObject("Word.Application")
objword.Visible = False
'open transfer doc
objword.Documents.Open Filename:=docpath2

'your loop code here to open files
objword.Documents.Open Filename:=docpath, ReadOnly:=False
' get doc contents
Set MyRange = objword.ActiveDocument.Content
'*method 1
'BigStr = MyRange.Text

'*method 2
MyRange.Copy

objword.ActiveDocument.Close savechanges:=False
objword.ActiveDocument.Select

'*method 1
'With objword.ActiveDocument
'.Content.InsertAfter BigStr
'End With

'*method 2
Set MyRange2 = objword.ActiveDocument.Range _
(Start:=objword.ActiveDocument.Content.End - 1, _
End:=objword.ActiveDocument.Content.End - 1)
MyRange2.Paste
'end loop

ErFix:
objword.ActiveDocument.Close savechanges:=True
objword.Quit
Set objword = Nothing
End Sub

 

[Mumba]

Awesome THANK YOU!!!

Did a few tweaks and it runs like a charm. Thank you very much for your help.

I got one followup question that i hope you can help me with. I need the paste to happen on the next page every time but it just won't happen for me?

 

[NdNoviceHlp]

I haven't trialled this and it is sort of dependent upon how you did your tweaks but it looks like this should work. Dave

'*method 2
Set MyRange2 = objword.ActiveDocument.Range _
(Start:=objword.ActiveDocument.Content.End - 1, _
End:=objword.ActiveDocument.Content.End - 1)
MyRange2.Paste
'*******new code goes here
Dim Cnt As Integer, LastPara As Integer
With objword.ActiveDocument
.Content.InsertAfter Chr(13)
LastPara = .Content.Paragraphs.Count
' chr13 on same page
If .Paragraphs(LastPara - 1).Range.Information(3) = _
.Paragraphs(LastPara).Range.Information(3) Then
Cnt = LastPara
Do Until .Paragraphs(Cnt).Range.Information(3) <> _
.Paragraphs(Cnt + 1).Range.Information(3)
.Content.InsertAfter Chr(13)
Cnt = Cnt + 1
Loop
End If
End With
'end loop

 

[Mumba]

Thanks again for the effort. Your suggestion above does not solve my troubles, unfortunely.

I inserted my code below and it basically runs except for 1 specific fil that activates the error handler every time.

The Error code says:
Run time error '4605'
This method or property is not available because the object refers to a framed paragraph

When trying your approach i runs, but there is not pagebreak. I keeps inserting right after the previous paste.

Sub CreateWordDocument()

Set wb = ActiveWorkbook
Set ws = wb.Worksheets("Selection")
lr = ws.Cells(100, "B").End(xlUp).Row
sr = 3

lc = ws.Cells(2, "AA").End(xlToLeft).Column

On Error GoTo ErFix

For i = lc To 2 Step -1
    If ws.Cells(2, i) = "Path" Then ColPath = i
    If ws.Cells(2, i) = "Applicable (Y/N)" Then ColChoise = i
Next

docpath2 = wb.Path & "\QMF-072_01 Framework agreement template.docx"

Set objword = CreateObject("Word.Application")
objword.Visible = True
objword.Documents.Open Filename:=docpath2 'open transfer doc (Template)
Set objWordData = objword.ActiveDocument
    objWordData.Content.Delete

For i = sr To lr
    If ws.Cells(i, ColChoise) <> "" And ws.Cells(i, ColPath) <> "" Then
        docpath = wb.Path & ws.Cells(i, ColPath) & ".docx"
        objword.Documents.Open Filename:=docpath, ReadOnly:=False 'Open file with data
        Set objWordTransfer = objword.ActiveDocument
        Set MyRange = objWordTransfer.Content
        Call Method2
        Application.CutCopyMode = False
        Set MyRange = Nothing
    End If
Next

objword.Visible = True

MsgBox "Word file is ready. Remember to save your file"
Application.CutCopyMode = False
Exit Sub

ErFix:
Set objword = Nothing
MsgBox "An error has occured, word file is not complete"
Application.CutCopyMode = False

End Sub

Sub Method2()

MyRange.Copy

objWordTransfer.Close savechanges:=False
objWordData.Activate

Set MyRange2 = objWordData.Range _
(Start:=objWordData.Content.End - 1, _
End:=objWordData.Content.End - 1)
MyRange2.Paste

If i < lr Then
    objWordData.Range(objWordData.Characters.Count - 1).InsertBreak Type:=7
End If
    
Set MyRange2 = Nothing

End Sub

 

[NdNoviceHlp]

Hi again Mumba. I don't know what a framed paragraph is? I set up this trial which work for me. The docs are in an array instead. Note that the code clears the transfer doc to start (comment out as needed). HTH. Dave

Option Explicit
Private Sub test()
Dim MyRange As Variant, docpath() As Variant, docpath2 As String, objword As Object
Dim BigStr As String, MyRange2 As Variant, Cnt2 As Integer
Dim Cnt As Integer, LastPara As Integer
docpath = Array("D:\testfolder\data.doc", "D:\testfolder\data2.doc", "D:\testfolder\data3.doc")
docpath2 = "D:\testfolder\transfer.doc"
On Error GoTo ErFix
Set objword = CreateObject("Word.Application")
objword.Visible = False
'open transfer doc
objword.Documents.Open Filename:=docpath2
'clear transfer doc
With objword.ActiveDocument
.Range(0, .Characters.Count).Delete
End With
'your loop code here to open files
For Cnt2 = LBound(docpath) To UBound(docpath)
objword.Documents.Open Filename:=docpath(Cnt2), ReadOnly:=False
' get doc contents
Set MyRange = objword.ActiveDocument.Content
'*method 1
'BigStr = MyRange.Text
'*method 2
MyRange.Copy
objword.ActiveDocument.Close savechanges:=False
objword.ActiveDocument.Select
'*method 1
'With objword.ActiveDocument
'.Content.InsertAfter BigStr
'End With
'*method 2
Set MyRange2 = objword.ActiveDocument.Range _
(Start:=objword.ActiveDocument.Content.End - 1, _
End:=objword.ActiveDocument.Content.End - 1)
MyRange2.Paste
'*******new code goes here
'paste on new page
With objword.ActiveDocument
.Content.InsertAfter Chr(13)
LastPara = .Content.Paragraphs.Count
' chr13 on same page
.Content.InsertAfter Chr(13)
If .Paragraphs(LastPara - 1).Range.Information(3) = _
.Paragraphs(LastPara).Range.Information(3) Then
Cnt = LastPara
Do Until .Paragraphs(Cnt).Range.Information(3) <> _
.Paragraphs(Cnt + 1).Range.Information(3)
.Content.InsertAfter Chr(13)
Cnt = Cnt + 1
Loop
End If
End With
Next Cnt2
MsgBox "Finished"
ErFix:
objword.ActiveDocument.Close savechanges:=True
objword.Quit
Set objword = Nothing
End Sub