Merge two word documents with VBA

[k1llrogg]

I have an excel table IN the word document with some data.
And i need to merge that with another word document which is a letter (i.e. replace the "First and Last name" with an actual First and Last name from the table in word document). But i only need to choose those people, who have value more than 220 in penultimate column in the table in word document.
As far as i know this code is only applicable with excel document:



MailMerge.OpenDataSource _
Name:=""
That's why i cant use this SQL-statement:



SELECT * FROM 'Лист1$'WHERE'...'>=220 And '...'='...'
How can i merge those 2 word documents?

[gmayor]

Is the Excel table an Excel object embedded in the document or a Word table copied from an Excel table?

[k1llrogg]

Is the Excel table an Excel object embedded in the document or a Word table copied from an Excel table?

I made a table in Excel and copied it to the Word document.

[gmayor]

In that case it is probably now in Word table form, in which case the following should help get you started

It assumes that you have two merge fields in the merge document (oTarget) "First" and "Last", that relate to columns 1 and 2 of the table respectively. Change the field names, the document names and locations as appropriate and run the macro.

If you have more merge fields, you can handle them in a similar manner.


Option Explicit
Sub Macro1()
Dim oSource As Document
Dim oTarget As Document
Dim oTable As Table
Dim oCell As Range
Dim oCode As Range
Dim oFld As Field
Dim iRow As Long, iCol As Long
Const strDocPath As String = "C:\Path\" 'The path where the documents are stored
Const strMergePath As String = "C:\Docs\" 'The path to save the merged letters
Set oSource = Documents.Open(strPath & "Data.docx") 'Open the document with the table
Set oTable = oSource.Tables(1)
For iRow = 1 To oTable.Rows.Count
iCol = oTable.Columns.Count - 1
Set oCell = oTable.Cell(iRow, iCol).Range
oCell.End = oCell.End - 1
If IsNumeric(oCell.Text) And Val(oCell.Text) > 220 Then 'Process only rows that have more than 220 in the next to last column
Set oTarget = Documents.Open(strPath & "Letter.docx") 'Open the merge document
oTarget.MailMerge.MainDocumentType = wdNotAMergeDocument
For Each oFld In oTarget.Fields
If oFld.Type = wdFieldMergeField Then
Set oCode = oFld.Code
oCode = Replace(LCase(oCode), "mergefield", "DOCVARIABLE")
End If
Next oFld
Set oCell = oTable.Cell(iRow, 1).Range
oCell.End = oCell.End - 1
oTarget.Variables("First").Value = oCell.Text
Set oCell = oTable.Cell(iRow, 2).Range
oCell.End = oCell.End - 1
oTarget.Variables("Last").Value = oCell.Text
oTarget.Fields.Update
For Each oFld In oTarget.Fields
If oFld.Type = wdFieldDocVariable Then
oFld.Unlink
End If
Next oFld
oTarget.SaveAs2 strMergePath & oTarget.Variables("Last").Value & _
oTarget.Variables("First").Value & ".docx"
oTarget.Close 0
End If
Next iRow
oSource.Close 0
lbl_Exit:
Set oSource = Nothing
Set oTarget = Nothing
Set oTable = Nothing
Set oCell = Nothing
Set oFld = Nothing
Set oCode = Nothing
Exit Sub
End Sub