-1

Im trying to create an excel tool that will add list item to sharepoint custom list. I had theinitial code but i am getying an error "couldnt find installable ISAM". My excel is 2016 and running in windows 10. How can i fix this issue?

Public Const sDEMAND_ROLE_GUID As String = "{6AA0B273-2548-49ED-9592-78243D4353AC}"
Public Const sSHAREPOINT_SITE As String = "https://eu001-sp.domain.com/sites/"

Sub TestPullFromSharepoint()

Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sConn As String
Dim sSQL As String
Dim ID As String

sConn = "Provider=Microsoft.ACE.OLEDB.12.0;DATABASE=" & sSHAREPOINT_SITE & ";" & _
"LIST=" & sDEMAND_ROLE_GUID & ";Extended Properties='Excel 8.0;HDR=YES;IMEX=1;';"

    Set cn = New ADODB.Connection
    Set rs = New ADODB.Recordset
    With cn
        .ConnectionString = sConn
        .Open
    End With
sSQL = "SELECT tbl.[name] FROM [Library Name] as tbl where tbl.[id] = 14"
rs.Open sSQL, cn, adOpenStatic, adLockOptimistic

End Sub
Community
  • 1
  • 1
Alexander Benson
  • 1
  • 1
  • 5

1 Answers1

0

I know it isn't super pretty, but I have a solution... Make sure that you replace YOURSHAREPOINTSITE with the url of your site.

The beauty of my solution, is that the code allows for:

  1. Creation of new SP list
  2. Addition of list items with all original column of the list
  3. Addition of list items with any number of columns of the list (as long as all required columns are represented)
  4. No link required for the addition of new data (does create a link when you use #1 but not a syncing link)

Limitations:

  1. Column validation will cause a failed run if you pass data that shouldn't go in that column (text to number column)
  2. Absent required columns cause a failed run
  3. Untested with lookup, people/group, or other record related column types... but it would cause invalid data, potentially a failed run unless you input the ID of the lookup value... which you probably don't have.
  4. It does require correct typing of column names and list name in input boxes...
Public Sub PushSPList()
    Dim lname As String, guid As String
    Dim arr, arrr
    Dim NewList As ListObject
    Dim L As ListObjects
    ' Get the collection of lists for the active sheet
    Set L = ThisWorkbook.ActiveSheet.ListObjects

    ' Add a new list
    If MsgBox("Have you selected the new data?", vbYesNo) = vbNo Then
        Exit Sub
    Else

        If MsgBox("New?", vbYesNo) = vbYes Then
            lname = InputBox("What is the name of your new list?")

            Set NewList = L.Add(xlSrcRange, Selection, , xlYes, True)
            NewList.Name = lname

            ' Publish it to a SharePoint site
            NewList.Publish Array("https://YOURSHAREPOINTSITE", lname), False

        Else
            arr = getSPitems
            lname = arr(2)
            guid = arr(1)

            Set NewList = L(1)
            Set arrr = Selection
            Call addSPListItem(arrr, lname, guid)

        End If
    End If

    End Sub

    Sub addSPListItem(rar As Variant, lnme, guid)

    Dim arr, lguid As String, spurl As String, lname As String, uitem As Object

    lguid = guid
    lname = lnme

    spurl = "https://YOURSHAREPOINTSITE"

    Dim cnt As ADODB.Connection
    Dim rst As ADODB.Recordset 'tb

    Dim mySQL As String

    Set cnt = New ADODB.Connection
    Set rst = New ADODB.Recordset

    mySQL = "SELECT * FROM [" & lname & "];"

    With cnt
        .ConnectionString = _
        "Provider=Microsoft.ACE.OLEDB.12.0;WSS;IMEX=0;RetrieveIds=Yes;" & _
            "DATABASE=" & spurl & _
            ";LIST=" & lguid & ";"
        .Open
    End With

    rst.Open mySQL, cnt, adOpenDynamic, adLockOptimistic


    Dim fld As Object
    Dim arrr()
    i = -1
    For Each fld In rst.Fields
    i = i + 1
    ReDim Preserve arrr(0 To i)
    arrr(i) = rst.Fields(i).Name

    Next

    Dim clmns
    clmns = Split(InputBox("Select columns, separated by commas, no spaces after commas...    " & Join(arrr, ", ")), ",")

    Dim Colmns As Object
    Set Colmns = CreateObject("Scripting.Dictionary")
    For i = 0 To UBound(clmns)
        Colmns(i) = clmns(i)
    Next

    jj = 1
    Do While rar(jj, 1)  ""
    rst.AddNew
        For kk = 0 To UBound(clmns)
        rst.Fields(Colmns(kk)) = rar(jj, kk + 1)
        Next
    jj = jj + 1
        Loop
    rst.Update

    If CBool(rst.State And adStateOpen) = True Then rst.Close
    Set rst = Nothing
    If CBool(cnt.State And adStateOpen) = True Then cnt.Close
    Set cnt = Nothing
    MsgBox "Done"
    End Sub
LlamaLoney
  • 1