sqlexcelvbasharepointmailmerge

VBA mailmerge can't access data source using .OpenDataSource and SQLStatement parameters


My company is transitioning to SharePoint at the moment and as such I'm having to update our VBA macros to deal with the move.

One of these macros involves using a CSV file and performing an SQLStatement call on it using the code shown below. I've not included all of the code as it's quite lengthy including parts that work as expected. Let me know if I need to include the whole thing (I've included a comment to signify the part of the code that is causing the error).

It gives the error: "Word was unable to open the data source".

''create a uniquely named CSV file that contains all merge data
randomiserString = Ctrl.Range("Timestamp").Value
currentDirectory = Wb1.Path
docTemplatePath = Ctrl.Range("Address_Merge_Template").Value
user = Application.UserName
modifiedUserString = Replace(user, " ", ".")
filepathDataCSV = "c:\Users\" + modifiedUserString + ".LWP\London Wall Partners LLP\London Wall Partners LLP - Administration\Development\Automation\Report Mail Merges\CSV dumps\" + randomiserString + ".csv"

''create the CSV
Wb1.Sheets("Data").Copy
'xlCSVUTF8 is required FileFormat for handling certain characters e.g. é or %.
ActiveWorkbook.SaveCopyAs Filename:=filepathDataCSV 'FileFormat:=xlCSVUTF8, CreateBackup:=False
ActiveWorkbook.Close

Ctrl.Range("Address_CSV").Value = filepathDataCSV

'Create Word file
Application.StatusBar = "Creating Word file..."
Set wApp = CreateObject("Word.Application")
wApp.Visible = True
Set wDoc = wApp.Documents.Add(Template:=docTemplatePath, NewTemplate:=False, DocumentType:=0)

'GoTo MailMergePrep:
ImportFromRecEng:
'Parameters for grabbing data and images from RecEng.  Includes a skip clause if no RecEng has been imported.
RecEngFilepath = Ctrl.Range("Address_RecEng").Value
Set RecEng = Workbooks.Open(RecEngFilepath)

'Section to insert tables into s3 and rec schedules.
For i = 0 To ArrayLength_RecsSummary
    If RecsSummary.Range("RecsSummaryAnchor").Offset(i + 1, 1).Value > 0 Then
        TableToCopy = RecsSummary.Range("RecsSummaryAnchor").Offset(i + 1).Value
         If wDoc.Bookmarks.Exists(TableToCopy) Then
         On Error Resume Next
         Debug.Print Range(TableToCopy).Rows.Count
          If Err = 1004 Then
          'Range does not exsist in RecEng
          Else
           If (InStr(1, TableToCopy, "Sells") <> 0 Or InStr(1, TableToCopy, "SwOut") <> 0) Then TableToCopy_Buys = RecsSummary.Range("RecsSummaryAnchor").Offset(i + 2).Value Else TableToCopy_Buys = "Null"
           RecEng.Activate
           Application.GoTo Range(TableToCopy)
          Selection.Copy
          wDoc.Activate
          wDoc.Bookmarks.DefaultSorting = wdSortByName
          wDoc.Bookmarks.ShowHidden = False
          wDoc.Bookmarks(TableToCopy).Select
          wApp.Selection.PasteSpecial Link:=False, DataType:=9, Placement:=0, DisplayAsIcon:=False
              If (InStr(1, TableToCopy, "Sells") <> 0 And InStr(1, TableToCopy_Buys, "Buys") <> 0) Or (InStr(1, TableToCopy, "SwOut") <> 0 And InStr(1, TableToCopy_Buys, "SwIn") <> 0) Or (InStr(1, TableToCopy, "Schedule") <> 0) Then
              With wApp.Selection
                .Collapse Direction:=wdCollapseEnd
                .TypeParagraph
              End With
              End If
        End If
        End If
    End If
    Err.Clear
    On Error GoTo 0
Next i
Application.CutCopyMode = False
RecEng.Close SaveChanges:=False

'Section for deleting irrelevant account blocks from s3.1 and s3.2.  CG 19/2/20: This should also work for the investment schedules.
For i = 0 To ArrayLength_RecsSummary4
    If RecsSummary.Range("RecsSummaryAnchor4").Offset(i + 1, 1).Value = 0 Then
        TableToDelete = RecsSummary.Range("RecsSummaryAnchor4").Offset(i + 1).Value
        If (TableToDelete <> "" And wDoc.Bookmarks.Exists(TableToDelete)) Then wDoc.Bookmarks(TableToDelete).Range.Cut
    End If
Next i

'Section for deleting irrelevant tables from s3.1 and s3.2.  CG 19/2/20: This should also work for the investment schedules.
For i = 0 To ArrayLength_RecsSummary
    If RecsSummary.Range("RecsSummaryAnchor").Offset(i + 1, 1).Value = 0 Then
        TableToDelete = RecsSummary.Range("RecsSummaryAnchor").Offset(i + 1).Value
        If (TableToDelete <> "" And wDoc.Bookmarks.Exists(TableToDelete) = True) Then wDoc.Bookmarks(TableToDelete).Range.Cut
        'If Sell table exists but Buy table doesn't, need to delete the line break before Buy table.  Could a "delete all blank lines" clause work?
    End If
Next i

'Section for deleting irrelevant paragraphs from s3.1 and s3.2.  CG 19/2/20: This should also work for the investment schedules.
For i = 0 To ArrayLength_RecsSummary3
    If RecsSummary.Range("RecsSummaryAnchor3").Offset(i + 1, 1).Value = 0 Then
        TableToDelete = RecsSummary.Range("RecsSummaryAnchor3").Offset(i + 1).Value
        If (TableToDelete <> "" And wDoc.Bookmarks.Exists(TableToDelete) = True) Then wDoc.Bookmarks(TableToDelete).Range.Cut
    End If
Next i
'Copy and paste s1 and 2
If Ctrl.Range("S1S2_Address").Value <> "" Then
    S1S2Filepath = Ctrl.Range("S1S2_Address").Value
    Doc_Path = S1S2Filepath
    Dim WordDoc As Word.Document
    Set wApp2 = CreateObject("Word.Application")
    wApp.Visible = True
    'Set WordDoc = wApp2.Documents.Open(Doc_Path, ReadOnly:=True)
    Set WordDoc = wApp2.Documents.Add(Template:=Doc_Path, NewTemplate:=False, DocumentType:=0)
    WordDoc.Range.Copy
    wDoc.Activate
    Set Rng = wDoc.Content
    Rng.Collapse Direction:=wdCollapseStart
    Rng.PasteAndFormat wdFormatOriginalFormatting
    'Rng.Paste
    WordDoc.Close SaveChanges:=False

End If
With wDoc.Sections(1).PageSetup
    .DifferentFirstPageHeaderFooter = True
End With

MailMergePrep:
'Prep the mail merge
'The next 6 lines are causing the issue
With wDoc.MailMerge
    .MainDocumentType = wdFormLetters
    sDBPath = filepathDataCSV
    .OpenDataSource Name:=sDBPath, SQLStatement:="SELECT * FROM `'Data$'`"
    .ViewMailMergeFieldCodes = wdToggle
End With

'Export the document.  NB loses connection to CSV.
Application.StatusBar = "Performing mail merge..."
With wDoc
    .MailMerge.Destination = wdSendToNewDocument
    .MailMerge.Execute Pause:=False
End With



wDoc.Close SaveChanges:=False

Application.DisplayAlerts = True
Application.ScreenUpdating = True

Application.StatusBar = False


MsgBox "Recommendations generated successfully and opened in Word."

Actions.Hide

'Application.StatusBar = False

End Sub

I've researched online and there's not too much documentation on this. The only advice I could find was that mail merge won't work at all if you're purely operating out of SharePoint online and should work if you use the OneDrive sync function. We have already set this up and that is what I'm testing on, however, the errors still persist. Thanks in advance for your help!


Solution

  • I would begin by checking if the CSV file exists in the specified sDBPath directory. To verify the existence of the CSV file in this path, I would insert a Debug.Print filepathDataCSV statement in the code below and then inspect the specified path to confirm the presence of the CSV file. :)

    ActiveWorkbook.SaveCopyAs Filename:=filepathDataCSV 'FileFormat:=xlCSVUTF8, CreateBackup:=False
      Debug.print filepathDataCSV 'get saved csv file path
    ActiveWorkbook.Close