使用Excel VBA向SharePoint人员/组字段批量上传数据

问题根源 #

ADODB Connection & Recordset仅能处理SharePoint列表中的常规文本、数字等基础字段，人员/组字段属于特殊复合字段，需要传入包含用户唯一标识（如用户ID）的特定格式值，而非单纯的邮箱文本，因此ADODB方式无法直接完成导入。

可行方案：用SharePoint REST API实现批量导入 #

通过VBA调用SharePoint REST API，先根据邮箱获取对应用户的SharePoint内部ID，再构造符合人员字段要求的格式提交数据。以下是完整可复用代码：

Option Explicit

' 替换为你的SharePoint站点URL
Const SP_SITE_URL As String = "https://yourcompany.sharepoint.com/sites/yourSite"
' 替换为目标列表名称
Const SP_LIST_NAME As String = "YourTargetList"
' 替换为Excel中常规文本字段的列名（对应SharePoint列表字段）
Const TEXT_FIELD_NAME As String = "Title"
' 替换为Excel中邮箱列名，以及对应SharePoint人员字段的内部名称
Const EMAIL_COLUMN As String = "Email"
Const SP_USER_FIELD_NAME As String = "AssignedTo"

Sub BatchUploadToSP()
    Dim ws As Worksheet
    Dim lastRow As Long
    Dim i As Long
    Dim email As String
    Dim userId As String
    Dim itemData As String
    Dim http As Object
    
    Set ws = ThisWorkbook.Sheets("Sheet1") ' 替换为你的数据工作表
    lastRow = ws.Cells(ws.Rows.Count, EMAIL_COLUMN).End(xlUp).Row
    
    ' 创建HTTP请求对象
    Set http = CreateObject("MSXML2.XMLHTTP.6.0")
    
    ' 遍历Excel数据行（从第2行开始，跳过表头）
    For i = 2 To lastRow
        email = Trim(ws.Cells(i, EMAIL_COLUMN).Value)
        If email <> "" Then
            ' 获取SharePoint用户ID
            userId = GetSPUserID(email, http)
            If userId <> "" Then
                ' 构造请求体：注意人员字段格式为 "Id": 用户ID
                itemData = "{""__metadata"": {""type"": ""SP.Data." & GetListEntityTypeName(SP_LIST_NAME, http) & """}, " & _
                            """" & TEXT_FIELD_NAME & """: """ & Trim(ws.Cells(i, TEXT_FIELD_NAME).Value) & """, " & _
                            """" & SP_USER_FIELD_NAME & """: {""results"": [{""Id"": " & userId & "}]}}"
                
                ' 提交数据到SharePoint列表
                If AddSPListItem(itemData, http) Then
                    ws.Cells(i, "Z").Value = "上传成功" ' 标记上传状态
                Else
                    ws.Cells(i, "Z").Value = "上传失败"
                End If
            Else
                ws.Cells(i, "Z").Value = "未找到该邮箱对应的用户"
            End If
        Else
            ws.Cells(i, "Z").Value = "邮箱为空"
        End If
    Next i
    
    Set http = Nothing
    MsgBox "批量上传完成"
End Sub

' 根据邮箱获取SharePoint用户ID
Function GetSPUserID(email As String, http As Object) As String
    Dim url As String
    Dim response As String
    Dim json As Object
    
    url = SP_SITE_URL & "/_api/web/SiteUsers/getByEmail('" & Replace(email, "'", "''") & "')/Id"
    
    With http
        .Open "GET", url, False
        .SetRequestHeader "Accept", "application/json;odata=verbose"
        .Send
        response = .ResponseText
    End With
    
    ' 解析JSON响应
    Set json = CreateObject("Scripting.Dictionary")
    ParseJSON response, json
    
    If json.Exists("d") Then
        GetSPUserID = json("d")("Id")
    Else
        GetSPUserID = ""
    End If
End Function

' 获取列表的实体类型名称（如SP.Data.YourTargetListListItem）
Function GetListEntityTypeName(listName As String, http As Object) As String
    Dim url As String
    Dim response As String
    Dim json As Object
    
    url = SP_SITE_URL & "/_api/web/lists/getByTitle('" & Replace(listName, "'", "''") & "')/ListItemEntityTypeFullName"
    
    With http
        .Open "GET", url, False
        .SetRequestHeader "Accept", "application/json;odata=verbose"
        .Send
        response = .ResponseText
    End With
    
    Set json = CreateObject("Scripting.Dictionary")
    ParseJSON response, json
    
    If json.Exists("d") Then
        GetListEntityTypeName = json("d")("ListItemEntityTypeFullName")
    Else
        GetListEntityTypeName = ""
    End If
End Function

' 添加列表项
Function AddSPListItem(itemData As String, http As Object) As Boolean
    Dim url As String
    Dim response As String
    
    url = SP_SITE_URL & "/_api/web/lists/getByTitle('" & Replace(SP_LIST_NAME, "'", "''") & "')/items"
    
    On Error Resume Next
    With http
        .Open "POST", url, False
        .SetRequestHeader "Accept", "application/json;odata=verbose"
        .SetRequestHeader "Content-Type", "application/json;odata=verbose"
        .SetRequestHeader "X-RequestDigest", GetRequestDigest(http)
        .Send itemData
        
        If .Status = 201 Then
            AddSPListItem = True
        Else
            AddSPListItem = False
        End If
    End With
    On Error GoTo 0
End Function

' 获取请求摘要（用于POST请求验证）
Function GetRequestDigest(http As Object) As String
    Dim url As String
    Dim response As String
    Dim json As Object
    
    url = SP_SITE_URL & "/_api/contextinfo"
    
    With http
        .Open "POST", url, False
        .SetRequestHeader "Accept", "application/json;odata=verbose"
        .Send ""
        response = .ResponseText
    End With
    
    Set json = CreateObject("Scripting.Dictionary")
    ParseJSON response, json
    
    If json.Exists("d") Then
        GetRequestDigest = json("d")("GetContextWebInformation")("FormDigestValue")
    Else
        GetRequestDigest = ""
    End If
End Function

' JSON解析辅助函数（无需额外引用的简易实现）
Sub ParseJSON(jsonString As String, dict As Object)
    Dim json As Object
    Set json = CreateObject("MSScriptControl.ScriptControl")
    json.Language = "JScript"
    json.AddCode "function parseJson(s) { return eval('(' + s + ')'); }"
    Set dict = json.Run("parseJson", jsonString)
End Sub

注意事项 #

• 需在VBA编辑器中添加Microsoft Scripting Runtime和Microsoft Script Control引用（工具→引用）
• 替换代码中所有大写常量为你的实际信息（站点URL、列表名、字段名等）
• 确保运行代码的账号拥有SharePoint列表的编辑权限
• Excel中的邮箱必须与全局地址簿（SharePoint用户池）中的邮箱完全匹配，否则无法获取用户ID

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