Code taking too long

[LetterFrack]

Hi ,I have written the following code and although it works correctly it is slow in executing. Can anyone help me in optimising its speed.

The user has to enter
- a resource
- a project
- a role
- a date range (i.e 2 drop downs - they select dates between the date in the first drop down and the date in the second drop down
- a percentage of the day
- type of booking

The code loops through the days that have been selected
if the user has already entered a certain resource , working on a certain project , fullfilling a certain role then if they change the percentage of time they are working on it or the type of booking the record is update

otherwise

a new record is added

Here is the code I would appreciate any help

Private Sub cmd_insert_Click()
'Declared the following variables

Dim q
    Dim db As DAO.Database
    Dim qdf As DAO.QueryDef
    Dim strSQL As String
    Dim strsql2 As String
    Set db = CurrentDb
    Dim recdetect
    Dim FDate As Date
Set qdf = db.QueryDefs("qry_append")

'this is just in case a user does not enter a value. If they dont do this
' a message box pops up informing them that they need to enter in 
' a value
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

'the user is selecting between a date range (i.e they slect when a booking 'begins and when it end
FDate = Cbo_startdate.Value
Do While FDate <= Cbo_enddate.Value

'Checks to see as to whether a booking has already been made for that resource who is working as a particular role on a particular project on a particular day


recdetect = DLookup("Resource_ID", "Resource_block", "[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 this is not the case
If IsNull(recdetect) Then
    strSQL = "INSERT INTO Resource_Block ( Block_Date, Resource_ID, Project_Id, Role_ID, Block_ID, Percentage)" _
    & "SELECT DISTINCT Day.[Week Beginning], Resource.Resource_ID, Project.Project_ID,Role.Role_ID," _
    & "Block.Block_ID, Percentage.Percentage_ID FROM Day, Resource, Role, Block, Percentage, " _
    & "Project where Resource.Resource_ID = " & cbo_resource.Value & " and Project.Project_ID = " _
    & "" & Cbo_project.Value & " and Role.Role_ID = " & cbo_role.Value & " and block.block_id = " & Cbo_block.Value & "" _
    & " and percentage.percentage_id = '" & cbo_percentage & "'" _
    & " and  Day.[Week Beginning] = #" & Format$(FDate, "mm/dd/yyyy") & "#"
    qdf.SQL = strSQL
    DoCmd.OpenQuery "qry_append"
    Else
'if the resource is already working on that project doing that for that day then

    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
'Goes to the next day that they have choosen
FDate = FDate + 1
Loop
Dim x
x = MsgBox("Booking Added")
Set qdf = Nothing
Set db = Nothing
Else
Dim qt
qt = MsgBox("You have not included all required fields", vbOKOnly)
End If
End Sub

 

[ecniv]

Hi

First up - don't use Dlookup - its crap and its slow.

Instead, amend your Sql statement to return in a data range (start to end) of records.

Then you can loop through them and add new records as appropriate. Perhaps.

You could (in theory) use two sql statements... Not sure if its possible but, well. 1) update the current details 2) add in missing details.
This may prove to be good.. or might not again, its up to you to test and see.


You could have a table of dates (I know a waste of time usually) which you filter then link (left join) to the resource allocation... Any that are null and not with the resource ID specified can be added, those with records returned may need updating.


Disclaimer
These are only suggestions, up to you to choose which may work or to try them all.