拆分Excel上传SharePoint时遇未授权错误求助

我使用VBA代码将一份Excel文件按「Owner」列拆分为多个独立Excel文件，再上传至SharePoint。执行过程中会弹出凭证输入窗口，但输入凭证后仍抛出**unauthorized（未授权）**错误。

实现代码 #

Private Sub CommandButton1_Click()
Dim ws As Worksheet
Dim tbl As ListObject
Dim lastRow As Long
Dim uniqueValues As Collection
Dim value As Variant
Dim newWorkbook As Workbook
Dim savePath As String
Dim headerToFilter As String
Dim headersToUnlock As Variant
Dim headerIndexFilter As Long
Dim headerIndexUnlock As Variant
Dim headerRange As Range
Dim fileName As String
Dim SPUrl As String
Dim SPFolder As String
Dim SPUsername As String
Dim SPPassword As String
Dim HTTPReq As Object

' Set SharePoint credentials and URLs
SPUrl = "https://mycompanysharepoint/:f:/s/TreasuryTransformation/"
SPFolder = "Shared%20Documents/General/PO%20Accrual/Excel%20to%20split" ' Path to the SharePoint document library folder
SPUsername = "myemailid@compamanydomain"
SPPassword = "password"
 
' Set the worksheet you want to process
Set ws = ThisWorkbook.Sheets("OpenPO") ' Replace "Sheet1" with your sheet name
Set splitws = ThisWorkbook.Sheets("Split excel")

' Set the table name you want to process
On Error Resume Next
Set tbl = ws.ListObjects("OpenPO") ' Replace "TableName" with your table name
On Error GoTo 0
If tbl Is Nothing Then
    MsgBox "Table 'OpenPO' not found!"
    Exit Sub
End If

' Set the header name you want to filter on
headerToFilter = "Owner" ' Replace "HeaderToFilter" with your header name for filtering
 
' Find the column index of the header to filter
On Error Resume Next
headerIndexFilter = tbl.ListColumns(headerToFilter).Index
On Error GoTo 0
If headerIndexFilter = 0 Then
    MsgBox "Header '" & headerToFilter & "' not found in the table!"
    Exit Sub
End If
 
' Check if there is data in the table
If tbl.DataBodyRange Is Nothing Then
    MsgBox "No data found in the table!"
    Exit Sub
End If

'Check if the filter column contains any Excel Error'
Dim cell As Range
For Each cell In tbl.ListColumns(headerIndexFilter).DataBodyRange
    If IsError(cell.value) Then
        MsgBox "Column '" & headerToFilter & "' contains Excel errors. Please Fix them and try again."
        Exit Sub
    ElseIf Application.WorksheetFunction.CountIf(tbl.ListColumns(headerIndexFilter).DataBodyRange, 0) > 0 Then
        MsgBox "Column '" & headerToFilter & "' has 0 in place of owner name. Please Fix them and try again."
        Exit Sub
    End If
Next cell
 
' Set the header names for columns to unlock
headersToUnlock = Array("Comment - Reporting Team", "Correction Journal Name") ' Replace with your header names to unlock
 
' Find the column indexes for headers to unlock
ReDim headerIndexUnlock(LBound(headersToUnlock) To UBound(headersToUnlock))
For i = LBound(headersToUnlock) To UBound(headersToUnlock)
    Set headerRange = tbl.HeaderRowRange.Find(headersToUnlock(i), LookIn:=xlValues, LookAt:=xlWhole)
    If Not headerRange Is Nothing Then
        headerIndexUnlock(i) = headerRange.Column
         MsgBox "Header '" & headersToUnlock(i) & "' found! at '" & headerRange.Column & "'"
    Else
        MsgBox "Header '" & headersToUnlock(i) & "' not found!"
        Exit Sub
    End If
Next i
 
' Get the last row of data in the table
lastRow = tbl.DataBodyRange.Rows.Count
 
' Create a collection to store unique values from the specified column
Set uniqueValues = New Collection
 
' Loop through the data and collect unique values
On Error Resume Next
For i = 1 To lastRow
    If tbl.DataBodyRange.Cells(i, headerIndexFilter).value <> "" Then
        uniqueValues.Add tbl.DataBodyRange.Cells(i, headerIndexFilter).value, CStr(tbl.DataBodyRange.Cells(i, headerIndexFilter).value)
    End If
Next i
On Error GoTo 0
 
' Loop through unique values and create separate workbooks
For Each value In uniqueValues
    If value <> "" Then
        ' Filter data based on unique values
        tbl.Range.AutoFilter Field:=headerIndexFilter, Criteria1:=value
 
        ' Copy visible cells to a new workbook
        Set newWorkbook = Workbooks.Add
        tbl.HeaderRowRange.Copy Destination:=newWorkbook.Sheets(1).Range("A1")
        tbl.DataBodyRange.SpecialCells(xlCellTypeVisible).Copy
        newWorkbook.Sheets(1).Range("A2").PasteSpecial Paste:=xlPasteValues ' Copy filtered data starting from row 2
        Application.CutCopyMode = False 'Clear clipboard
        
        ' Apply formatting
        With newWorkbook.Sheets(1)
            .Range("A1").CurrentRegion.Columns.AutoFit
            .Range("A1").CurrentRegion.Borders.LineStyle = xlContinuous
            .Range("A1").CurrentRegion.Font.Bold = True
        End With
        
        ' Unfilter the original data
        tbl.Range.AutoFilter Field:=headerIndexFilter
        
        ' Lock all cells by default
            newWorkbook.Sheets(1).Cells.Locked = True

            ' Unlock specific columns
            For Each headerIndexUnlockValue In headerIndexUnlock
                newWorkbook.Sheets(1).Columns(headerIndexUnlockValue).Locked = False
            Next headerIndexUnlockValue

            ' Protect the sheet
            newWorkbook.Sheets(1).Protect Password:="test", UserInterfaceOnly:=True

            ' Generate dynamic file name with date and time
            fileName = "Split_" & value & "_" & Format(Now, "yyyy-mm-dd_hh-mm-ss") & ".xlsx"

            ' Set the save path and filename
            savePath = Environ("TEMP") & "\" & fileName ' Temporary path with dynamic file name

            ' Save the new workbook temporarily
            newWorkbook.SaveAs savePath
            newWorkbook.Close SaveChanges:=False
            
           
            ' Upload file to SharePoint
            Set HTTPReq = CreateObject("MSXML2.XMLHTTP")
            HTTPReq.Open "PUT", SPUrl & "/_api/web/GetFolderByServiceRelativeUrl('" & SPFolder & "')/Files/Add(url='" & fileName & "', overwrite=true)", False
            HTTPReq.setRequestHeader "Content-Type", "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet"
            HTTPReq.setRequestHeader "X-FORMS_BASED_AUTH_ACCEPTED", "f"
            HTTPReq.setRequestHeader "Authorization", "Basic " & Base64Encode(SPUsername & ":" & SPPassword)

            ' Open the file to be uploaded
            Dim fileStream As Object
            Set fileStream = CreateObject("ADODB.Stream")
            fileStream.Open
            fileStream.Type = 1 ' Binary
            fileStream.LoadFromFile savePath

            ' Send the request to upload the file
            HTTPReq.Send fileStream.Read

            ' Check if the upload was successful
            If HTTPReq.Status = 200 Then
                MsgBox "File uploaded successfully to SharePoint."
            Else
                MsgBox "Error uploading file to SharePoint: " & HTTPReq.statusText
                Exit Sub
            End If

            ' Clean up
            fileStream.Close
            Set fileStream = Nothing
            Set HTTPReq = Nothing

            ' Delete the temporary file
            Kill savePath
    End If
Next value

MsgBox "Split and upload operation completed successfully!"
End Sub

    Private Function Base64Encode(ByVal sText As String) As String
Dim arrData() As Byte
arrData = StrConv(sText, vbFromUnicode)
Dim objXML As Object
Dim objNode As Object
Set objXML = CreateObject("MSXML2.DOMDocument")
Set objNode = objXML.createElement("b64")
objNode.DataType = "bin.base64"
objNode.nodeTypedValue = arrData
Base64Encode = objNode.Text
Set objNode = Nothing
Set objXML = Nothing
End Function

代码执行流程 #

• 指定SharePoint凭证与目标路径
• 检查目标表格是否存在、数据是否合法（无错误值、无无效Owner）
• 提取Owner列的唯一值，为每个值生成独立Excel文件
• 设置工作表保护：默认锁定所有单元格，仅指定列可编辑
• 临时保存文件后，通过SharePoint REST API上传文件

凭证输入弹窗 #

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