Code too slow - would arrays be better

[LetterFrack]

My database app using the following is working effectively but it is dog slow.

The app deals with assigning resources to projects.
The user selects a resource a project and the date for which the user is on the project. This is accomplished by having a drop down with a startdate and a drop down with an enddate on the form.

The code then loops through these dates , checking each date to ensure that the resource has not already been booked on the project on that date. If it has the previous record is updated.
If not the row is added.


This is really slow - can anyone advise me as to a better way of creating my code. Regards



Private Sub cmd_insert_Click()


Dim q
Dim db As DAO.Database
Dim strSQL As String
Set db = CurrentDb


Dim fdate As Date


Set db = CurrentDb()
Dim rst As Recordset






If cbo_resource.Value <> 0 And Cbo_project.Value <> 0 And cbo_role.Value <> 0 And Cbo_block <> 0 And cbo_percentage <> 0 And Cbo_startdate.Value <> "" And Cbo_enddate.Value <> "" Then
fdate = Cbo_startdate.Value
Do While fdate <= Cbo_enddate.Value

Set rst = db.OpenRecordset("Select * from resource_block where resource_id = " & cbo_resource.Value & " " _
& " and role_id = " & cbo_role.Value & " and project_id = " & Cbo_project.Value & " " _
& " and block_date >= #" & Format$(fdate, "mm/dd/yyyy") & "# ")

If rst.EOF = True Then

'insert these records which are not in this array

strSQL = "INSERT INTO Resource_Block ( Block_Date, Resource_ID, Project_Id, Role_ID, Block_ID, Percentage)" _
& " values(('" & fdate & "'),(" & cbo_resource.Value & "),(" & Cbo_project.Value & "), " _
& "(" & cbo_role.Value & "), " _
& " (" & Cbo_block.Value & "),('" & cbo_percentage.Value & "'))"
DoCmd.RunSQL strSQL
Else
strSQL = "UPDATE Resource_Block SET block_id = " & Cbo_block.Value & " , percentage='" & cbo_percentage.Value & "'" _
& " WHERE (resource_id=" & cbo_resource.Value & " and role_id = " & cbo_role.Value & " and project_id = " & Cbo_project.Value & " " _
& " and block_date = #" & Format$(fdate, "mm/dd/yyyy") & "# )"

DoCmd.RunSQL strSQL
End If
fdate = fdate + 1
Loop
Dim x
x = MsgBox("Booking Added")
Set db = Nothing
rst.Close ' When done we eliminate Recordset
Set rst = Nothing
Else
Dim qt
qt = MsgBox("You have not included all required fields", vbOKOnly)
End If
End Sub

 

[EMP]

Maybe updating in one batch and using DCount() instead of opening recordset can speed up processing:-

Private Sub cmd_insert_Click()

  If IsNull(cbo_resource) Or IsNull(Cbo_project) Or _
     IsNull(cbo_role) Or IsNull(Cbo_block) Or IsNull(cbo_percentage) Or _
     IsNull(Cbo_startdate) Or IsNull(Cbo_enddate) Then
    MsgBox "You have not included all required fields", vbOKOnly
    Exit Sub
  End If
   
  Dim db As DAO.Database
  Dim strSQL As String
  Dim fdate As Date

  Set db = CurrentDb()
   
  ' update in one batch  
  strSQL = "UPDATE Resource_Block SET block_id = " & Cbo_block _
       & ", percentage='" & cbo_percentage & "'" _
       & " WHERE (resource_id=" & cbo_resource _
       & " and role_id = " & cbo_role & " and project_id = " & Cbo_project _
       & " and block_date BETWEEN #" & Format$(Cbo_startdate, "mm/dd/yyyy") _
       & "# AND #" & Format$(Cbo_enddate, "mm/dd/yyyy") & "#)"
    
  DoCmd.RunSQL strSQL
    
  fdate = Cbo_startdate.Value
  Do While fdate <= Cbo_enddate.Value
     
    If DCount("*", "resource_block", "resource_id = " & cbo_resource _
       & " and role_id = " & cbo_role & " and project_id = " & Cbo_project _
       & " and block_date = #" & Format$(fdate, "mm/dd/yyyy") & "# ") = 0 Then
          
       'insert these records which are not in this array
       strSQL = "INSERT INTO Resource_Block" _
         & "(Block_Date, Resource_ID, Project_Id, Role_ID, Block_ID, Percentage)" _
         & " values(('" & fdate & "'),(" & cbo_resource & ")," _
         & "(" & Cbo_project & "), " & "(" & cbo_role & ")," _
         & "(" & Cbo_block & "),('" & cbo_percentage & "'))"
       
       DoCmd.RunSQL strSQL

    End If
    fdate = fdate + 1
  Loop
    
   MsgBox "Booking Added"
   Set db = Nothing
 
End Sub