none
Need guidance on VBA Function to update SharePoint List RRS feed

  • Question

  • Hi Folks -

    I have the following VBA Function to update a SharePoint List (RD_PFC_3LEVEL_List) from a file that I have linked to the MS Access Database. This function works great - there are no issues - but it takes awhile to update.  The table is RD_PFC_3LEVEL_List is 8500 records and about 30 columns and takes around 15 minutes to run.

    What I would prefer to do is ONLY update the records that need to be updated. I can easily add a where clause to the sRS recordset to use an additonal column from my source to determine what records need to be updated.  However, the way I have my Function setup, it still goes through every redcord in the RD_PFC_3LEVEL_List table.  How would I go about acheiving this?

    Thanks!

    Function Update_RD_PFC_3LEVEL_List()
    On Error Resume Next
        
        Dim dbs As DAO.Database
        Dim sRS As DAO.Recordset
        Dim tRS As DAO.Recordset
        Dim tRSMV As DAO.Recordset
        Dim fld As DAO.Field2
        
        Dim sTable As String
        Dim tTable As String
        Dim strTempTable As String
           
        Dim tgtStr, srcStr As String
        Dim vStr() As String
        Dim tFlds, sFlds, vCriteria As String
        Dim tFld() As String
        Dim sFld() As String
        
        Dim i, z As Integer
        Dim strMask As String
        Dim strFunctName As String
        Dim strTimeDiff As String
        Dim strStartTime As Date
        Dim strEndTime As Date
        Dim strResult As String
        Dim strProcError As String
        
        Set ws = DBEngine.Workspaces(0)
        Set dbs = ws.Databases(0)
        
        On Error GoTo Proc_Err
        
        'start a transaction to ensure all updates are run or rolled back
        ws.BeginTrans: strTFlag = 1
        
        strFunctName = "Update_RD_PFC_3LEVEL_List": strStartTime = Format(Now, "mm/dd/yyyy hh:mm:ss")
        strMask = "PFP*"
        sTable = "MDM_Project_Portfolio_Reference": strTempTable = "LT" & sTable
        tTable = "RD_PFC_3LEVEL_List"
        strFlag = ""
           
        tFlds = "[Name],[Parent_Node],[Alias],[Alliance_Partner],[Brand_Name],[Direct_Flag],[IP_Owner],[Modality],[Orphan_Designation],[Pass_Through],[Phase_Nominal],[Status]," & _
                "[Protocol_Number],[PTS_Region],[Pool_Target],[ASC_CMC_MODEL_T],[ASC_DEV_MODEL_T],[ASC_PRD_MODEL_T],[ASC_GAO_MODEL_I],[PrePostCS],[TA],[ProjectType]," & _
                "[Research_Code],[PRD_DDU],[Indication_Code],[Indication_Desc],[Time_Tracking],[Alternate_Name],[Development_Name],[Fin_Alloc_Target],[Finance_TA_Grouping]," & _
                "[Modality_Detail],[Target_Long_Name],[Target_Short_Name],[Mechanism],[Business_Owner],[IR-Disclosure],[Route_of_Administration],[NME_LCM],[Protocol_Phase],[Protocol_Status]," & _
                "[Protocol_Title],[Trial_ID],[Parent_Alias],[Grandparent_Node],[Grandparent_Alias]"
        sFlds = "[Name],[Parent Node],[Alias],[Partner_Alias_Link],[Brand Name],[Direct Flag],[IP Owner],[Modality],[Orphan Designation],[Pass Through],[Phase (Nominal)],[Portfolio Status]," & _
                "[Protocol Number],[PTS Region],[Pool - Target Property],[ASC_CMC_MODEL_T],[ASC_DEV_MODEL_T],[ASC_PRD_MODEL_T],[ASC_GAO_MODEL_I],[PrePostCS],[PF_TherapeuticArea],[ProjectType]," & _
                "[PF_Research_Code],[PRD_DDU],[IND_CODE],[IND_DESC],[Time_Tracking],[Alternate_Name],[Development_Name],[Fin_Alloc_Target],[Finance_TA_Grouping]," & _
                "[Modality_Detail],[Target Long Name],[Target_Short_Name],[Mechanism],[Business_Owner],[IR - Disclosure],[Route_of_Administration],[NME_LCM],[Protocol_Phase],[Protocol_Status]," & _
                "[Protocol_Title],[Trial_ID],[Parent_Alias],[Grand Parent],[GrandParent_Alias]"
    
        strTList = "": strSList = ""
        strTQryR = Replace(tFlds, strTList, ""): strSQryR = Replace(sFlds, strSList, "")
     
        strFldsQry = sTable & Replace(sFlds, ",", ", " & "[" & sTable & "].")
        strFldsQry = Replace(strFldsQry, sTable & "[Name]", "[" & sTable & "]" & "." & "[" & "Name" & "]")
        
        tFld = Split(tFlds, ",")
        sFld = Split(sFlds, ",")
        
        strStep = "Step 1 : Purge [" & tTable & "] of records that have moved to Research rollup"
        strSQL = "" & _
                "DELETE FROM [" & tTable & "]" & _
                "WHERE NOT EXISTS (SELECT 1" & _
                                   " FROM [" & sTable & "]" & _
                                   " WHERE [" & sTable & "].[Name] = [" & tTable & "].[Name]" & _
                                     " AND [" & sTable & "].[Parent Node] = [" & tTable & "].[Parent_Node]" & _
                                   ")"
        dbs.Execute strSQL, dbFailOnError
        strSQL = ""
               
        strStep = "Step 2 : Add New Data Elements"
        strSQL = "" & _
                "INSERT INTO [" & tTable & "] (" & _
                    tFlds & _
                " )" & _
                " SELECT" & _
                    strFldsQry & _
                " FROM [" & sTable & "]" & _
                " LEFT JOIN [" & tTable & "] ON [" & tTable & "].[Name] = [" & sTable & "].[Name]" & _
                " WHERE (( [" & sTable & "].[Name] LIKE '" & strMask & "'" & _
                    " AND [" & sTable & "].[Parent Node] LIKE 'PFI-*' )" & _
                    " AND ([" & tTable & "].[Name] IS NULL));"
        dbs.Execute strSQL, dbFailOnError
        strStep = ""
          
        'Clear Variables
        strStep = "": srcStr = "": tgtStr = ""
    
        'Open a table-type Recordset
        Set sRS = dbs.OpenRecordset("Select * from [" & sTable & "] where [Name] like """ & strMask & """", dbOpenDynaset)
        Set tRS = dbs.OpenRecordset(tTable, dbOpenDynaset)
      
        Do Until tRS.EOF
        
            srcStr = "": tgtStr = ""
            
                vCriteria = "Name = '" & tRS.Fields("Name").value & "'"
                sRS.MoveFirst
                sRS.FindFirst vCriteria
    
                'Do Standard field mapping property updates
                For i = 0 To UBound(tFld)
                
                    'Set fld to check .IsComplex property
                    Set fld = tRS(tFld(i))
                    
                    strStep = "Update Data Element Attributes" & vbNewLine & vbNewLine & _
                              "Data Element - " & Nz(tRS.Fields("Name").value, "") & vbNewLine & _
                              "Source Field - " & Nz(sFld(i), "") & vbNewLine & _
                              "Source Value - " & Nz(sRS.Fields(sFld(i)).value, "") & vbNewLine & _
                              "Target Field - " & Nz(tFld(i), "") & vbNewLine & _
                              "Target Value - " & Nz(tRS.Fields(tFld(i)).value, "")
                    'Ignore MVF Attributes
                    If Not fld.IsComplex Then
                        If Nz(tRS.Fields(tFld(i)).value, "foo") <> Nz(sRS.Fields(sFld(i)).value, "foo") Then
                            tRS.Edit
                            tRS.Fields(tFld(i)).value = sRS.Fields(sFld(i)).value
                            tRS.Update
                        End If
                     End If
                Next
            tRS.MoveNext
        Loop
        
        'commit all changes
        ws.CommitTrans: strTFlag = 0
        
        Set sRS = Nothing
        Set tRS = Nothing
        Set tRSMV = Nothing
    
    Proc_Exit:
    
        '::-- Update Start & End Times --::'
        If strResult = "" Then strResult = "Success"
        strEndTime = Format(Now, "mm/dd/yyyy hh:mm:ss")
        strTimeDiff = strEndTime - strStartTime
        Call ADD_RUN_TIMES(strFunctName, strStartTime, strEndTime, _
                           Hour(strTimeDiff) & " hours " & Minute(strTimeDiff) & " minutes " & Second(strTimeDiff) & " seconds", _
                           strResult, _
                           strProcError _
                           )
           
        Set ws = Nothing
        Set dbs = Nothing
        Exit Function
    
    Proc_Err:
    
        strResult = "Failed"
        strProcError = Err.Description
    
        If Len(strStep) > 0 Then
            EmailStep = strStep & vbNewLine & vbNewLine
        Else
            EmailStep = ""
        End If
        
        strSubject = "WARNING : Function '" & strFunctName & "' Failed"
        strBody = strSubject & vbNewLine & vbNewLine & _
                  EmailStep & _
                  "Profile : " & CurrentUser() & vbNewLine & vbNewLine & _
                  "VB Module : " & Application.VBE.ActiveCodePane.CodeModule.name & vbNewLine & vbNewLine & _
                  "VB Error : " & Err.Description
        strTo = "email@client.com"
        Call MDM_Routines.Email_Utility(strSubject, strBody, strTo, "", "")
        
        If strTFlag = 1 Then ws.Rollback
        
        Resume Proc_Exit
        
    End Function


    Monday, June 1, 2020 12:05 PM