我的公司目前正在过渡到 SharePoint，因此我必须更新我们的 VBA 宏来应对这一转变。
其中一个宏涉及使用 CSV 文件并使用下面所示的代码对其执行 SQLStatement 调用。我没有包含所有代码，因为它相当冗长，包括按预期工作的部分。让我知道是否需要包含整个内容（我已包含注释来表示导致错误的代码部分）。
它给出错误：“Word 无法打开数据源”。
''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
我在网上进行了研究，没有太多关于这方面的文档。我能找到的唯一建议是，如果您纯粹在 SharePoint Online 上操作，则邮件合并根本不起作用，而如果您使用 OneDrive 同步功能，则邮件合并应该起作用。我们已经进行了设置，这就是我正在测试的内容，但是错误仍然存在。预先感谢您的帮助！
我首先检查指定的 sDBPath 目录中是否存在 CSV 文件。为了验证此路径中是否存在 CSV 文件，我将在下面的代码中插入一条 Debug.Print filepathDataCSV 语句，然后检查指定的路径以确认 CSV 文件是否存在。 :)
ActiveWorkbook.SaveCopyAs Filename:=filepathDataCSV 'FileFormat:=xlCSVUTF8, CreateBackup:=False
Debug.print filepathDataCSV 'get saved csv file path
ActiveWorkbook.Close