VBA to Add new row to sharepoint from excel file

Question

In my Excel workbook I have a table with dimensions same as sharepoint-online list. I want to add rows to sharepoint-online list if its added to excel table. I have followed, following code to do so but HTTP status is not 201 and an error keeps coming

Error creating list item: 403 -

what I am doing wrong?

    Sub AddRowsToSharePoint()
    Dim ws As Worksheet
    Dim lr As Long
    Dim i As Long
    Dim objHTTP As Object
    Dim strURL As String
    Dim strJSON As String
    
    ' Set the worksheet containing the data
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    
    ' Get the last row with data in column A
    lr = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row
    
    ' Loop through each row and create new list item in SharePoint
    For i = 2 To lr ' Assuming row 1 contains headers
        ' Set the SharePoint site URL and list name
        strURL = "https://creditsuisseapc.sharepoint.com/sites/GF_Innovation_New/_api/web/lists/getbytitle('testingMicro')/items"
        
        ' Build the JSON payload to create a new list item
        strJSON = "{""__metadata"":{""type"":""SP.Data.testingMicroListItem""},"
        strJSON = strJSON & """Title"":""" & ws.Range("A" & i).Value & ""","
        strJSON = strJSON & """Column1"":""" & ws.Range("B" & i).Value & ""","
        strJSON = strJSON & """Column2"":""" & ws.Range("C" & i).Value & """}"
        
        ' Create a new HTTP request object
        Set objHTTP = CreateObject("MSXML2.XMLHTTP")
        
        ' Open a connection to SharePoint and send the request
        objHTTP.Open "POST", strURL, False
        objHTTP.setRequestHeader "Accept", "application/json;odata=verbose"
        objHTTP.setRequestHeader "Content-Type", "application/json;odata=verbose"
        objHTTP.setRequestHeader "X-RequestDigest", GetRequestDigest(strURL)
        objHTTP.send strJSON
        
        
        ' Check the HTTP response status code
        If objHTTP.Status <> 201 Then
            Debug.Print "Error creating list item: " & objHTTP.Status & " - " & objHTTP.statusText
        End If
        
        ' Clean up the HTTP request object
        Set objHTTP = Nothing
    Next i
   End Sub

  Function GetRequestDigest(strURL As String) As String
    Dim objHTTP As Object
    Dim strJSON As String
    Dim strDigest As String
    
    ' Create a new HTTP request object
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    
    ' Open a connection to SharePoint and send the request
    objHTTP.Open "POST", strURL & "/contextinfo", False
    objHTTP.setRequestHeader "Accept", "application/json;odata=verbose"
    objHTTP.send
    
    ' Parse the JSON response and extract the request digest value
    strJSON = objHTTP.responseText
    strDigest = Mid(strJSON, InStr(strJSON, """FormDigestValue"":""") + 19, 56)
    
    ' Clean up the HTTP request object
    Set objHTTP = Nothing
    
    ' Return the request digest value
    GetRequestDigest = strDigest
End Function

VBA to Add new row to sharepoint from excel file

0 Answers0