Sub Sharepoint_update()

 

   Application.ScreenUpdating = False    '描画停止

   Application.EnableEvents = False    'イベント抑制

   Application.DisplayAlerts = False   '表示抑制

  

  Dim cn As Object 'ADODB.Connection

  Dim rs As Object 'ADODB.Recordset

  Dim strSQL As String

  Dim DateSQL

  Dim testSQL

  Dim StrManagementNoSQL As String

  Dim getDate

  getDate = "#" & Date & "#"

 

'定期メールからダウンロードしたファイルを開いてwb1とする

Dim OpenFileName

Dim wScriptHost As Object

Dim wb1 As Workbook

Dim SalesDataBase As Worksheet

 

  'カレントディレクトリをデスクトップに変更

  Set wScriptHost = CreateObject("WScript.Shell")

    ChDir wScriptHost.SpecialFolders("Desktop")

    MsgBox "定期メールからダウンロードしたファイルを開いてください", vbInformation

    OpenFileName = Application.GetOpenFilename("Microsoft Excelブック,*.xls?")

    If OpenFileName <> "False" Then

        Workbooks.Open OpenFileName

    Else

         MsgBox "キャンセルがクリックされました。終了します。", vbInformation

         End

    End If

   Set wb1 = ActiveWorkbook  '定期メールからダウンロードしたファイル=wb1

 

  

    Const SharePointUrl As String = "https://sharepoint.com/teams/test/"

  Const ListId As String = "{xxxxx-xxx-xx}"

  

  Set cn = CreateObject("ADODB.Connection")

  cn.Open "Provider=Microsoft.ACE.OLEDB.16.0;WSS;IMEX=2;RetrieveIds=Yes;DATABASE=" & SharePointUrl & ";LIST=" & ListId & ";" 'プロバイダーは適宜変更

      strSQL = "SELECT Location FROM ListId WHERE Location = ""TESTTEST"";"

     Debug.Print strSQL

  Set dbRes = CreateObject("ADODB.Recordset")

    dbRes.Open strSQL, cn, adOpenKeyset, adLockReadOnly

        ' シート初期化

   ' Set objSh = ThisWorkbook.Worksheets(1)

    With wb1

        lngRow = 1

        ' 先頭レコードからEOFまで繰り返す

        Do Until dbRes.EOF

            ' 行を加算

            lngRow = lngRow + 1

            Debug.Print lngRow

            ' 全列をシートに展開

            For lngCol = 0 To 8

                .Cells(lngRow, lngCol + 1).Value = dbRes.Fields(lngCol).Value

            Next lngCol

            ' 次のレコードに移る

            dbRes.MoveNext

        Loop

    End With

    ' レコードセット、データベースを閉じる

    dbRes.Close

    Set dbRes = Nothing

    cn.Close

End Sub