Hi Spy128Bit -

Good show. Your persistence paid off with the filtering approach.

Interestingly though, I ran your procedure(s) and couldn't get your reported
performance on my test data; no matter, but I'm curious why. It might be the
way I ginned up 32000+ records or some other reason. Below is my version.
It processes 32,400 records in 4 minutes and 15 seconds on my PC (2.66 Core 2
Duo, 2GB Ram, XL2003/WinXPPro-SP2). I expect our platforms would be fairly
similar in performance.

Could you run my procedure on your data and report back with execution time
? It would be of general interest, but also it's an opportunity to shake
down performance concepts.
--
Jay


Option Base 1

Sub Logic_Beta_V2()
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''
'V2 uses arrays and calculates overlap within the procedure (does
'not call the overlap function).
'This version processes 32,400 records in 4 minutes and 15 seconds.
'''''''''''''''''''''''''''''''''''''''''''''''''' '''''''''''

startTime = Timer
Dim rngDB As Range
Dim lrow As Long
Dim uniqueWho As New Collection
Dim calc() As Variant

'Size up the data range
Set rngDB = Range("A1").CurrentRegion
lrow = rngDB.Rows.Count + rngDB.Row - 1
Set rngDB = rngDB.Offset(1, 0).Resize(rngDB.Rows.Count - 1, _
rngDB.Columns.Count)
Set rngWho = rngDB.Columns(2)

'Set the excel environment conditions
oldStatusBar = Application.DisplayStatusBar
Application.DisplayStatusBar = True
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False

'1. Build a collection of unique names in 'Who' field
'using NewCollection technique; store in 'uniqueWho' collection
On Error Resume Next ' ignore any errors
For Each cl In rngWho.Cells 'rngDB.Columns(2).Cells
uniqueWho.Add cl.Value, cl.Value ' add the unique item
Next 'cl
On Error GoTo 0

'2. For each unique name in database...
For Each strWho In uniqueWho
iw = iw + 1 'counter for statusbar
idx = 0
ReDim calc(1 To rngDB.Rows.Count, 1 To 3) 'reinitialize used array
'Use With Block and DoLoop to search through entire 'Who' column
'to find all matching names. Load data from matching rows into into
'calc array.
With rngWho
Set h = .Find(strWho, LookIn:=xlValues, Lookat:=xlWhole)
If Not h Is Nothing Then
h_address1 = h.Address
Do
idx = idx + 1
calc(idx, 1) = h.Row 'worksheet row number
calc(idx, 2) = h.Offset(0, 4) 'start time
calc(idx, 3) = h.Offset(0, 5) 'finish time
Set h = .FindNext(h)
Loop While Not h Is Nothing And h.Address < h_address1
End If
End With

'Cycle through calc array to calculate overlaps for current strWho
'and write results to activesheet one-by-one.
For i = 1 To idx
'i is the index for the 'base' start (calc(i,2)) and
'finish (calc(i,3)) times
Z = 0
'Then, calculate overlap for each matching record
'and accumulate in variable Z
For j = 1 To idx
'j is the index for the common start (calc(j,2)) and
'finish (calc(j,3)) times
If calc(i, 2) < calc(j, 2) Then
ovrlap = calc(i, 3) - calc(j, 2)
Else
ovrlap = calc(j, 3) - calc(i, 2)
End If
If ovrlap < 0 Then ovrlap = 0
ovrlap = ovrlap * 1440
Z = Z + ovrlap

Next j
Cells(calc(i, 1), 11) = Z 'store result in column K
Next i

Next 'strWho (next unique person)

endTime = Timer

Application.EnableEvents = True
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True

'Formulate and display completion dialog message
wrapProcedu
s = startTime: e = endTime
If Round((e - s) / 60, 1) 0.9 Then
If Round((e - s) / 60, 1) < 2 Then mplural = "" Else mplural = "s"
If ((e - s) / 60 - Int((e - s) / 60)) * 60 <= 1 Then _
splural = "." Else splural = "s."
cTime = Int((e - s) / 60) & " minute" & mplural & " and " & _
Format(Round(((e - s) / 60 - Int((e - s) / 60)) * 60, 1), "##.#") & _
" second" & splural
Else
If e - s <= 1 Then splural = "." Else splural = "s."
cTime = Format(Round((e - s), 1), "##.#") & " second" & splural
If e - s < 0.1 Then cTime = "less than 0.1 second."
End If
MsgBox "Procedure completed successfully in " & cTime, vbInformation

End Sub