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!
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