迁移至SharePoint后VBA邮件合并调用OpenDataSource失败

我司正迁移至SharePoint平台，需更新现有VBA宏。其中一款宏依赖CSV文件，通过SQLStatement语句调用数据执行邮件合并操作，但运行时抛出「Word无法打开数据源」错误。已完成OneDrive同步功能配置（已知纯SharePoint Online环境下邮件合并无法运行，需依赖该同步功能），但错误仍未解决，恳请协助排查。

相关代码如下：

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

排查方向及解决方案 #

• SQL语句适配问题：
  代码中SQL语句使用SELECT * FROM 'Data$'`，但CSV是单表文件，并非Excel工作簿，无需指定工作表名称。可修改SQL语句为匹配CSV文件名，或直接移除SQLStatement参数：

  ' 修改方式1：匹配CSV文件名
  .OpenDataSource Name:=sDBPath, SQLStatement:="SELECT * FROM `" & randomiserString & ".csv`"
  ' 修改方式2：移除SQLStatement参数，让Word自动识别
  .OpenDataSource Name:=sDBPath
  

• CSV编码格式问题：
  当前用SaveCopyAs保存CSV，无法应用注释中提到的xlCSVUTF8格式，需改用SaveAs：

  ActiveWorkbook.SaveAs Filename:=filepathDataCSV, FileFormat:=xlCSVUTF8, CreateBackup:=False
  

• 路径与权限验证：
  通过Debug.Print filepathDataCSV输出路径，确认文件是否存在且位于OneDrive同步目录内，同时检查当前用户对该路径的读写权限。也可临时将CSV保存到本地临时目录（如Environ("TEMP")）测试是否能正常读取。
• 手动验证数据源：
  手动打开Word模板，尝试手动连接生成的CSV文件，排除文件本身或Word配置的问题。

内容的提问来源于stack exchange，提问作者MaxArkell