Excel VBA向SharePoint列表添加记录时触发自动化错误的排查

从Stack Overflow获取的VBA代码用于将记录从Excel写入SharePoint列表，运行时出现Excel VBA Automation Error Exception Occurred错误，直接导致Excel 365崩溃。已按微软社区建议添加AccessibilityCplAdmin 1.0 Type Library引用，但问题仍未解决。以下是已验证连接字符串的代码：

Sub AddItem()
' Requires a reference to "Microsoft ActiveX Data Object 6.0 Libray" to insert a record into a sharepoint list "AccessLog"
' Requires a reference to AccessibilityCplAdmin 1.0 Type Library
    Dim cnt As ADODB.Connection
    Dim rst As ADODB.Recordset
    Dim mySQL As String

    Set cnt = New ADODB.Connection
    Set rst = New ADODB.Recordset
   ‘Renewal is the name of my table
    mySQL = "SELECT * FROM [Renewal];"

    With cnt ' See https://www.connectionstrings.com/sharepoint/

'Writes only
.ConnectionString = _
      "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;" _
    & "DATABASE=http://mysharepointsite.com/documents/;LIST={5999B8A0-0C2F-4D4D-9C5A-D7B146E49698};"
        .Open
    End With

    rst.Open mySQL, cnt, adOpenDynamic, adLockOptimistic

    rst.AddNew
        rst.Fields("RequestType") = "RequestType"
        rst.Fields("Group") = "Group"
        rst.Fields("Requester") = "Requester"
        rst.Fields("RequestDate") = "RequestDate"
        rst.Fields("Unit") = "Unit"
        rst.Fields("Full VIN") = "Full VIN"
        rst.Fields("State") = "State"
        rst.Fields("Plate Number") = "Plate Number"
        rst.Fields("Vehicle needs sticker (X)") = "Vehicle needs sticker (X)"
        rst.Fields("Vehicle needs plate (X)") = "Vehicle needs plate (X)"
        rst.Fields("Comments") = "Comments"
    rst.Update ' commit changes to SP list

    If CBool(rst.State And adStateOpen) = True Then rst.Close
    If CBool(cnt.State And adStateOpen) = True Then cnt.Close
    
    
    MsgBox "Your submission has been received."
End Sub

错误原因分析 #

• 不必要的引用引发冲突：AccessibilityCplAdmin 1.0 Type Library是用于系统辅助功能设置的库，和SharePoint数据操作完全无关，添加该引用会与ADODB、Office组件产生兼容性冲突，直接触发崩溃。
• 字段赋值逻辑错误：代码中所有字段都被硬编码赋值为字段名本身（如rst.Fields("RequestType") = "RequestType"），若SharePoint列表字段为日期、数字等非文本类型，会触发数据类型不匹配错误，进而引发自动化异常。
• 连接字符串路径错误：DATABASE=http://mysharepointsite.com/documents/指向的是文档库路径，ACE.OLEDB连接SharePoint列表时需指向网站根地址，而非文档库子路径。
• 全量记录集加载风险：使用adOpenDynamic+adLockOptimistic打开全量列表记录集，若列表数据量大，会占用大量内存，导致Excel资源耗尽崩溃。

解决办法 #

1. 移除无效引用 #

打开VBA编辑器 → 工具 → 引用，取消勾选AccessibilityCplAdmin 1.0 Type Library，仅保留Microsoft ActiveX Data Objects 6.0 Library即可。

2. 修正字段赋值逻辑 #

将硬编码的字段名替换为Excel单元格的实际值，假设数据存放在Sheet1的A2:K2行，修改如下：

rst.AddNew
    rst.Fields("RequestType") = Sheet1.Range("A2").Value
    rst.Fields("Group") = Sheet1.Range("B2").Value
    rst.Fields("Requester") = Sheet1.Range("C2").Value
    rst.Fields("RequestDate") = Sheet1.Range("D2").Value
    rst.Fields("Unit") = Sheet1.Range("E2").Value
    rst.Fields("Full VIN") = Sheet1.Range("F2").Value
    rst.Fields("State") = Sheet1.Range("G2").Value
    rst.Fields("Plate Number") = Sheet1.Range("H2").Value
    rst.Fields("Vehicle needs sticker (X)") = Sheet1.Range("I2").Value
    rst.Fields("Vehicle needs plate (X)") = Sheet1.Range("J2").Value
    rst.Fields("Comments") = Sheet1.Range("K2").Value
rst.Update

3. 修正连接字符串 #

将DATABASE路径改为SharePoint网站根地址：

.ConnectionString = _
  "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;" _
& "DATABASE=http://mysharepointsite.com/;LIST={5999B8A0-0C2F-4D4D-9C5A-D7B146E49698};"

4. 优化数据写入方式 #

无需加载全量记录集，直接使用INSERT INTO语句写入数据，减少内存占用：

' 替换原Recordset相关代码，直接通过Connection执行SQL
mySQL = "INSERT INTO [Renewal] (RequestType, [Group], Requester, RequestDate, Unit, [Full VIN], State, [Plate Number], [Vehicle needs sticker (X)], [Vehicle needs plate (X)], Comments) " & _
        "VALUES ('" & Replace(Sheet1.Range("A2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("B2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("C2").Value, "'", "''") & "', #" & Sheet1.Range("D2").Value & "#, '" & Replace(Sheet1.Range("E2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("F2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("G2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("H2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("I2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("J2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("K2").Value, "'", "''") & "')"
cnt.Execute mySQL

注：使用Replace函数将字段值中的单引号替换为两个单引号，避免SQL语法错误。

5. 添加错误捕获机制 #

加入错误处理逻辑，避免崩溃并精准定位问题：

Sub AddItem()
    On Error GoTo ErrorHandler
    Dim cnt As ADODB.Connection
    Dim mySQL As String

    Set cnt = New ADODB.Connection
    mySQL = "INSERT INTO [Renewal] (RequestType, [Group], Requester, RequestDate, Unit, [Full VIN], State, [Plate Number], [Vehicle needs sticker (X)], [Vehicle needs plate (X)], Comments) " & _
            "VALUES ('" & Replace(Sheet1.Range("A2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("B2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("C2").Value, "'", "''") & "', #" & Sheet1.Range("D2").Value & "#, '" & Replace(Sheet1.Range("E2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("F2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("G2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("H2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("I2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("J2").Value, "'", "''") & "', '" & Replace(Sheet1.Range("K2").Value, "'", "''") & "')"

    With cnt
        .ConnectionString = _
          "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;" _
        & "DATABASE=http://mysharepointsite.com/;LIST={5999B8A0-0C2F-4D4D-9C5A-D7B146E49698};"
        .Open
        .Execute mySQL
    End With

    MsgBox "Your submission has been received."

ExitSub:
    If CBool(cnt.State And adStateOpen) = True Then cnt.Close
    Set cnt = Nothing
    Exit Sub
    
ErrorHandler:
    MsgBox "错误代码：" & Err.Number & vbCrLf & "错误描述：" & Err.Description
    Resume ExitSub
End Sub

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