VBA from Excel to Word (Mail Merge) - Hosted on SharePoint

[agent_maxine]

Dear Mr. Excel,
First of all, thank you kindly for the wealth of information stored in this forum - it has helped me tremendously in my recent projects!

I am trying to extract cell values from Excel to complete a Word template. I have completed Mail Merge tags on Word and it works beautifully... when the files are in local drive.
Unfortunately our shared files are hosted on SharePoint... It appears that Mail Merge is not possible when the Excel/Word files are hosted there.

I had this idea to perhaps copy both the Excel/Word files onto Windows Temp folder*, complete Mail Merge, copy the Merged Word file back into initial SharePoint folder, then delete the copies from Temp folder. How do I structure the VBA script to accomplish this?

*(or another folder within local drive where the file path remains the same for all users - for example, path to my Desktop includes my specific Company ID and thus cannot use it for everyone. Unless there is a way around it!)

I am currently looking at this past discussion and would like to build around this:
https://www.mrexcel.com/forum/gener...ons/975319-excel-vba-run-mail-merge-word.html

 

[Macropod]

My bad. Before the first line:

.Close SaveChanges:=False

insert:

WordPath = .Path & "\"

That should cause the output document to be saved in the same folder as the mailmerge main document.

 

[agent_maxine]

This is what I'm using. For some reason it gives me an error with this portion:

.SaveAs FileName:=.Path & "\" & StrName & ".docx"

It worked just fine when I didn't have the & "" portion... But then it was saving it in My Documents folder haha
I tweaked the code because I don't need the full WordPath for SaveAs, just the initial .Path

Also (and now I'm just being nit-picky), I would like to automatically re-size the row height to 0.25" per one line of text in each box? I was looking at Dynamically Autofit Row Height in VBA however it seemed to be more specific on which column the height is dependent on.

Sub Excel_to_Word()

Dim Sheet As Worksheet, wsName As String, DataSource As String, WordPath As String
Dim WordApp As New Word.Application, WordDoc As Word.Document, Tbl As Word.Table
Dim StrName As String, r As Long

With ActiveWorkbook
    DataSource = .FullName
    WordPath = .Path & "\QUOTE.docx"
    wsName = .Sheets("Transfer").Name
    StrName = .Sheets("Transfer").Range("W2").Text & " - " & .Sheets("Transfer").Range("B2").Text
End With

With WordApp
    .Visible = True
    .DisplayAlerts = wdAlertsNone
    Set WordDoc = .Documents.Open(WordPath, AddToRecentFiles:=False)
    With WordDoc
        'Select Data Source and Complete Mail Merge
        With .Mailmerge
            .MainDocumentType = wdFormLetters
            .Destination = wdSendToNewDocument
            .OpenDataSource Name:=DataSource, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
                AddToRecentFiles:=False, PassWordDocument:="", PasswordTemplate:="", WritePassWordDocument:="", _
                WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, SubType:=wdMergeSubTypeAccess, _
                Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=DataSource;Mode=Read;" & _
                "Extended Properties=""HDR=YES;IME", SQLStatement:="SELECT * FROM `" & wsName & "$`", SQLStatement1:=""
            With .DataSource
                .FirstRecord = wdDefaultFirstRecord
                .LastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=False
        End With
        .Close SaveChanges:=False
    End With
    With .ActiveDocument
        For Each Tbl In .Tables
            With Tbl
                .AllowAutoFit = False
                For r = .Rows.Count To 1 Step -1
                    With .Rows(r)
                        If Len(.Range.Text) = .Cells.Count * 2 + 2 Then .Delete
                    End With
                Next
            End With
        Next
        .SaveAs FileName:=.Path & "\" & StrName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    End With
    .DisplayAlerts = wdAlertsAll
End With

Set WordDoc = Nothing: Set WordApp = Nothing

End Sub

 

[Macropod]

This is what I'm using. For some reason it gives me an error with this portion:

.SaveAs FileName:=.Path & "\" & StrName & ".docx"

It worked just fine when I didn't have the & "" portion... But then it was saving it in My Documents folder haha
I tweaked the code because I don't need the full WordPath for SaveAs, just the initial .Path

But the change you made isn't what I suggested. Had you done as I suggested, your output document would have been saved back to the same folder as the mailmerge main document (i.e. "the initial .Path").

Also (and now I'm just being nit-picky), I would like to automatically re-size the row height to 0.25" per one line of text in each box? I was looking at Dynamically Autofit Row Height in VBA however it seemed to be more specific on which column the height is dependent on.

I have no idea what textbox you're referring to - this is the first time you've mentioned one. Your link refers to rows heights in Excel, not to textboxes in Excel or Word.

 

[agent_maxine]

*Edit: I edited the codes per your suggestion and it worked perfectly! Shouldn't have doubted haha. Thanks again for all your help!

I am already using WordPath to retrieve the Word template file. Is it ok to re-define it in the same Sub?

As for the row height - yes it was the first time I mentioned it. The Word template has a lot of text boxes and I wanted to make sure the row height will be adjusted to fit all the texts... Wasn't sure if ".AllowAutoFit = False" would restrict the row height as well. But it does adjust to fit the texts so all good there

 

[Macropod]

I am already using WordPath to retrieve the Word template file. Is it ok to re-define it in the same Sub?

Sure you can. Indeed, that's precisely what the 'For Each Tbl In .Tables ... Next' loop does with the Tbl variable; on each iteration is points to a different table. Similarly with the 'For r = .Rows.Count To 1 Step -1 ... Next' loop.

Wasn't sure if ".AllowAutoFit = False" would restrict the row height as well

AllowAutoFit = False has nothing to do with row heights (only column/table widths), besides which your reference to 'boxes' implied textboxes, not table cells. Couple that with a reference to 'Autofit Row Height. in Excel and everything became very ambiguous.

Word doesn't have an autofit property for cells; if you don't specify a row height, row heights will expand/contract automatically. Word tables also have an 'At Least' row height property, which prevents a row's height decreasing below a set minimum.

 

[agent_maxine]

I see. Thank you for the info. It works really great now and I am now including a mail merge of another document in the same sub. I duplicated the middle "With" section for the Document #2 (but omitted the commands to delete the empty rows as I actually need them for Document #2 ). There is an error on the ".SaveAs FileName:=Document2Path ..." line. I imagine there is a cleaner way to automate multiple mail-merge of documents...

"Automation Error
The Object invoked has disconnected from its clients."

Sub Generate_Document1_Document2()

Dim Sheet As Worksheet, SheetName As String, DataSource As String, Document1Path As String, Document2Path As String
Dim WordApp As New Word.Application, WordDoc As Word.Document, Tbl As Word.Table
Dim Document1Name As String, Document2Name As String, r As Long

With ActiveWorkbook
    DataSource = .FullName
    Document1Path = .Path & "\Document1.docx"
    Document2Path = .Path & "\Document2.docx"
    SheetName = .Sheets("Transfer").Name
    Document1Name = .Sheets("Transfer").Range("U2").Text & " - Document1"
    Document2Name = .Sheets("Transfer").Range("U2").Text & " - Document2"
End With

With WordApp
    .Visible = True
    .DisplayAlerts = wdAlertsNone
    Set WordDoc = .Documents.Open(Document1Path, AddToRecentFiles:=False)
    With WordDoc
        'Select Data Source and Complete Mail Merge
        With .Mailmerge
            .MainDocumentType = wdFormLetters
            .Destination = wdSendToNewDocument
            .OpenDataSource Name:=DataSource, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
                AddToRecentFiles:=False, PassWordDocument:="", PasswordTemplate:="", WritePassWordDocument:="", _
                WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, SubType:=wdMergeSubTypeAccess, _
                Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=DataSource;Mode=Read;" & _
                "Extended Properties=""HDR=YES;IME", SQLStatement:="SELECT * FROM `" & SheetName & "$`", SQLStatement1:=""
            With .DataSource
                .FirstRecord = wdDefaultFirstRecord
                .LastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=False
        End With
        BindPath = .Path & "\"
        .Close SaveChanges:=False
    End With
    With .ActiveDocument
        For Each Tbl In .Tables
            With Tbl
                .AllowAutoFit = False
                For r = .Rows.Count To 1 Step -1
                    With .Rows(r)
                        If Len(.Range.Text) = .Cells.Count * 2 + 2 Then .Delete
                    End With
                Next
            End With
        Next
        .SaveAs FileName:=BindPath & Document1Name & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    End With
    .DisplayAlerts = wdAlertsAll
End With

Set WordDoc = Nothing: Set WordApp = Nothing

With WordApp
    .Visible = True
    .DisplayAlerts = wdAlertsNone
    Set WordDoc = .Documents.Open(Document2Path, AddToRecentFiles:=False)
    With WordDoc
        'Select Data Source and Complete Mail Merge
        With .Mailmerge
            .MainDocumentType = wdFormLetters
            .Destination = wdSendToNewDocument
            .OpenDataSource Name:=DataSource, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
                AddToRecentFiles:=False, PassWordDocument:="", PasswordTemplate:="", WritePassWordDocument:="", _
                WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, SubType:=wdMergeSubTypeAccess, _
                Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=DataSource;Mode=Read;" & _
                "Extended Properties=""HDR=YES;IME", SQLStatement:="SELECT * FROM `" & SheetName & "$`", SQLStatement1:=""
            With .DataSource
                .FirstRecord = wdDefaultFirstRecord
                .LastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=False
        End With
        Document2Path = .Path & "\"
        .Close SaveChanges:=False
        .SaveAs FileName:=Document2Path & Document2Name & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    End With
    .DisplayAlerts = wdAlertsAll
End With

Set WordDoc = Nothing: Set WordApp = Nothing

End Sub

 

[Macropod]

Try:

Sub Generate_Document1_Document2()
Dim WordApp As New Word.Application, WordDoc As Word.Document, Tbl As Word.Table
Dim Sheet As Worksheet, SheetName As String, DataSource As String, r As Long
Dim Document1Path As String, Document2Path As String
Dim Document1Name As String, Document2Name As String

With ActiveWorkbook
    DataSource = .FullName
    Document1Path = .Path & "\Document1.docx"
    Document2Path = .Path & "\Document2.docx"
    SheetName = .Sheets("Transfer").Name
    Document1Name = .Sheets("Transfer").Range("U2").Text & " - Document1"
    Document2Name = .Sheets("Transfer").Range("U2").Text & " - Document2"
End With

With WordApp
    .Visible = True
    .DisplayAlerts = wdAlertsNone
    
    Set WordDoc = .Documents.Open(Document1Path, AddToRecentFiles:=False)
    With WordDoc
        'Select Data Source and Complete Mail Merge
        With .Mailmerge
            .MainDocumentType = wdFormLetters
            .Destination = wdSendToNewDocument
            .OpenDataSource Name:=DataSource, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
                AddToRecentFiles:=False, PassWordDocument:="", PasswordTemplate:="", WritePassWordDocument:="", _
                WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, SubType:=wdMergeSubTypeAccess, _
                Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=DataSource;Mode=Read;" & _
                "Extended Properties=""HDR=YES;IME", SQLStatement:="SELECT * FROM `" & SheetName & "$`", SQLStatement1:=""
            With .DataSource
                .FirstRecord = wdDefaultFirstRecord
                .LastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=False
        End With
        Document1Path = .Path & "\"
        .Close SaveChanges:=False
    End With
    With .ActiveDocument
        For Each Tbl In .Tables
            With Tbl
                .AllowAutoFit = False
                For r = .Rows.Count To 1 Step -1
                    With .Rows(r)
                        If Len(.Range.Text) = .Cells.Count * 2 + 2 Then .Delete
                    End With
                Next
            End With
        Next
        .SaveAs Filename:=Document1Path & Document1Name & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    End With
    
    Set WordDoc = .Documents.Open(Document2Path, AddToRecentFiles:=False)
    With WordDoc
        'Select Data Source and Complete Mail Merge
        With .Mailmerge
            .MainDocumentType = wdFormLetters
            .Destination = wdSendToNewDocument
            .OpenDataSource Name:=DataSource, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
                AddToRecentFiles:=False, PassWordDocument:="", PasswordTemplate:="", WritePassWordDocument:="", _
                WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, SubType:=wdMergeSubTypeAccess, _
                Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=DataSource;Mode=Read;" & _
                "Extended Properties=""HDR=YES;IME", SQLStatement:="SELECT * FROM `" & SheetName & "$`", SQLStatement1:=""
            With .DataSource
                .FirstRecord = wdDefaultFirstRecord
                .LastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=False
        End With
        Document2Path = .Path & "\"
        .Close SaveChanges:=False
    End With
    .ActiveDocument.SaveAs Filename:=Document2Path & Document2Name & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    .DisplayAlerts = wdAlertsAll
End With

Set WordDoc = Nothing: Set WordApp = Nothing
End Sub

 

[agent_maxine]

*Edit to Correct: Document 1 is being saved twice, under both Document 1 Name and Document 2 Name, and Document 2 is not saved.

Tried the codes I am no longer getting the Run-time error, however Document 1 is being saved with Document 2's name, and Document 2 remains open with "Letters2".

 

[Macropod]

After:
.SaveAs Filename:=Document1Path & Document1Name & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
insert:
.Close SaveChanges:=False
and, if you want to view that document once the second merge has occurred, before:
.DisplayAlerts = wdAlertsAll
insert:
.Documents.Open Document1Path & Document1Name & ".docx", AddToRecentFiles:=False

 

[agent_maxine]

Hi Paul, hope you've been well.

Looking to enhance this MailMerge script here. I would like to close all open Word documents and kill any orphaned Word sessions prior to running any MailMerge.
I inserted the following in the script prior to starting the MailMerge.

With wordApp
.ScreenUpdating = False
Do Until .Documents.Count = 0 'Loop Through Open Word Documents
.Close SaveChanges:=True 'Close - Save
Loop
.Quit SaveChanges:=True 'Quit - Save
End With

Set wordApp = Nothing

It generates "Compile Error: Method or data member not found" at the ".Close" command. When I comment out this line, the script runs without closing any of the open Word document... and the ".Quit" command doesn't take any effect (i.e. Word application remains open the whole time).

Sub Generate_Document()

Dim WordApp As New Word.Application, WordDoc As Word.Document, Tbl As Word.Table
Dim Sheet As Worksheet, SheetName As String, DataSource As String, r As Long
Dim DocumentPath As String, DocumentName As String

With ActiveWorkbook
    DataSource = .FullName
    DocumentPath = .Path & "\Document.docx"
    SheetName = .Sheets("Transfer").Name
    DocumentName = .Sheets("Transfer").Range("A1").Text & " - Document"
End With

With wordApp
    .ScreenUpdating = False
    Do Until .Documents.Count = 0 'Loop Through Open Word Documents
        .Close SaveChanges:=True 'Close - Save
    Loop
    .Quit SaveChanges:=True 'Quit - Save
End With

Set wordApp = Nothing

With WordApp
    .Visible = True
    .DisplayAlerts = wdAlertsNone
    
    Set WordDoc = .Documents.Open(DocumentPath, AddToRecentFiles:=False)
    With WordDoc
        'Select Data Source and Complete Mail Merge
        With .Mailmerge
            .MainDocumentType = wdFormLetters
            .Destination = wdSendToNewDocument
            .OpenDataSource Name:=DataSource, ConfirmConversions:=False, ReadOnly:=False, LinkToSource:=True, _
                AddToRecentFiles:=False, PassWordDocument:="", PasswordTemplate:="", WritePassWordDocument:="", _
                WritePasswordTemplate:="", Revert:=False, Format:=wdOpenFormatAuto, SubType:=wdMergeSubTypeAccess, _
                Connection:="Provider=Microsoft.ACE.OLEDB.12.0;User ID=Admin;Data Source=DataSource;Mode=Read;" & _
                "Extended Properties=""HDR=YES;IME", SQLStatement:="SELECT * FROM `" & SheetName & "$`", SQLStatement1:=""
            With .DataSource
                .FirstRecord = wdDefaultFirstRecord
                .LastRecord = wdDefaultLastRecord
            End With
            .Execute Pause:=False
        End With
        DocumentPath = .Path & "\"
        .Close SaveChanges:=False
    End With
    With .ActiveDocument
        For Each Tbl In .Tables
            With Tbl
                .AllowAutoFit = False
                For r = .Rows.Count To 1 Step -1
                    With .Rows(r)
                        If Len(.Range.Text) = .Cells.Count * 2 + 2 Then .Delete
                    End With
                Next
            End With
        Next
        .SaveAs Filename:=DocumentPath & DocumentName & ".docx", FileFormat:=wdFormatXMLDocument, AddToRecentFiles:=False
    End With
    .DisplayAlerts = wdAlertsAll
End With

Set WordDoc = Nothing: Set WordApp = Nothing

End Sub