Function Efficiency 2

[BenUK]

The function I have below is taking between 6 and 8 seconds to process per record, has anyone any idea's how I can speed it up?

The main field being processed is a 1500 character memo field.

Thanks Ben



Public Function GoGadgetGo(activityCode, scheduleStart, scheduleCode, attributeValue, exceptID)

Dim db As Database
Dim rec As DAO.Recordset
Dim rec2 As DAO.Recordset
Dim codeTrue() As Integer, codeFalse() As Integer, maxVal As Integer

Set db = CurrentDb
Set rec2 = db.OpenRecordset("SELECT Count(attrval.ATTR_VALUE_NAME) FROM attrval WHERE (((attrval.ATTR_ID) = 1));", dbOpenDynaset)

maxVal = rec2(0)

rec2.Close

ReDim codeTrue(maxVal)
ReDim codeFalse(maxVal)

For i = scheduleStart To (scheduleStart + (Len(scheduleCode) - 1))

activity = Right(Left(activityCode, i), 1)
schedule = Right(Left(scheduleCode, i), 1)

activity = Asc(activity)
schedule = Asc(schedule)

Set rec = db.OpenRecordset("SELECT attrmap.ATTR_VALUE_ID FROM attrmap WHERE (((attrmap.ATTR_ID) = 1) And ((attrmap.EXC_ID) =" & schedule & &quot);", dbOpenDynaset)

If activity = schedule Then
codeTrue(rec(0)) = codeTrue(rec(0)) + 1
Else: codeFalse(rec(0)) = codeFalse(rec(0)) + 1
End If

rec.Close

Next

Set db = Nothing

For i = 1 To maxVal

codeTrue(i) = IIf(codeTrue(i) = Empty, 0, codeTrue(i))
codeFalse(i) = IIf(codeFalse(i) = Empty, 0, codeFalse(i))

GoGadgetGo = GoGadgetGo & codeTrue(i) & "," & codeFalse(i) & ","

Next

i = Len(GoGadgetGo)
GoGadgetGo = Left(GoGadgetGo, i - 1)

End Function

 

[jrbarnett]

Ben,

I have found a few parameters that are passed into the function which aren't used, so I have taken them out which is why I have changed the function name. I hope that this is a start.

Regards,

John

Public Function GoGadgetGo2 (activityCode As Integer, scheduleStart As Integer, scheduleCode As Integer)

Dim codeTrue() As Integer, codeFalse() As Integer, maxVal As Integer
Dim i As Integer
Dim Activity As Integer
Dim Schedule As Integer
Dim intSchedule As Integer

maxVal = DCount ("*", "attrval", "ATTR_ID = 1")


For i = scheduleStart To (scheduleStart + (Len(scheduleCode) - 1))

  activity = Right(Left(activityCode, i), 1)
  schedule = Right(Left(scheduleCode, i), 1)

  activity = Asc(activity)
  schedule = Asc(schedule)

  intSchedule = DLookup ("ATTR_VALUE_ID", "ATTRMAP", "ATTRMAP.ATTR_ID=1 AND ATTRMAP.EXC_ID = " & schedule
  If activity = schedule Then
   codeTrue(intSchedule) = codeTrue(intSchedule) + 1
  Else
   codeFalse(intSchedule) = codeFalse(intSchedule) + 1
  End If

Next i

For i = 1 To maxVal
  codeTrue(i) = IIf(codeTrue(i) = Empty, 0, codeTrue(i))
  codeFalse(i) = IIf(codeFalse(i) = Empty, 0, codeFalse(i))

  GoGadgetGo2 = GoGadgetGo & codeTrue(i) & "," & codeFalse(i) & ","
Next

i = Len(GoGadgetGo)
GoGadgetGo2 = Left(GoGadgetGo, i - 1)

End Function

 

[Norris68]

Open 'rec' once, containing all the records with ATTR_ID=1 before your loop and use the FindFirst function to look up EXC_ID within each loop instead of opening a recordset each time.

Open rec & rec2 as snapshots - you are not updating the data, so a read-only recordset will be more efficient.

Try using the Mid() function instead of your Right(Left()) combination.

Your final conversion of Empty values in your integer arrays in unnecessary - the array will be automatically initialised to zeroes when it is created/dimensioned.

 

[BenUK]

Thanks guys, I have used information from both your posts and now the processing time is down to under 5 seconds for the whole query!

The revised query is below

Thanks again
Ben



Public Function GoGadgetGo(activityCode, scheduleStart, scheduleCode)

Dim db As Database
Dim adhVal As DAO.Recordset
Dim maxVal As DAO.Recordset
Dim codeTrue() As Integer, codeFalse() As Integer, i As Integer
Dim activity As Variant, schedule As Variant

Set db = CurrentDb
Set maxVal = db.OpenRecordset("SELECT Count(attrval.ATTR_VALUE_NAME) FROM attrval WHERE (((attrval.ATTR_ID) = 1));", dbOpenSnapshot)
Set adhVal = db.OpenRecordset("SELECT attrmap.EXC_ID, attrmap.ATTR_VALUE_ID FROM attrmap WHERE ((attrmap.ATTR_ID) = 1);", dbOpenSnapshot)

ReDim codeTrue(maxVal(0))
ReDim codeFalse(maxVal(0))

For i = scheduleStart To (scheduleStart + (Len(scheduleCode) - 1))

activity = Mid(activityCode, i, 1)
schedule = Mid(scheduleCode, (i - scheduleStart + 1), 1)

activity = Asc(activity)
schedule = Asc(schedule)

adhVal.FindFirst ("EXC_ID = " & schedule)

If activity = schedule Then
codeTrue(adhVal(1)) = codeTrue(adhVal(1)) + 1
Else: codeFalse(adhVal(1)) = codeFalse(adhVal(1)) + 1
End If

Next

For i = 1 To maxVal(0)

GoGadgetGo = GoGadgetGo & codeTrue(i) & "," & codeFalse(i) & ","

Next

End Function

 

[jrbarnett]

Ben

You are opening your recordset objects but not closing them - this is likely to cause problems in the future.

Put
Maxval.Close
adhVal.Close

after the "Next" and before "End Function" to tidy up.

John

 

[BenUK]

Thanks John - I closed them in the original function, but forgot in the new function

Thanks again
Ben