Slow script

[YvorL]

Hi!

I've about 30-50 thousand row of data from a database. To fetch these data it takes about 3 seconds.
But I've to "filter" these results and it takes about 12 minutes... I don't think that this has to take that much time, if you have any suggestion please help.


The columns are:
- task unique ID (not the database unique ID only the tasks)
- employee ID
- current state
- other ID (depending on state)
others are irrelevant.

What I've to do is that if a task unique ID is on the list more than 2 times, then I've have to check if the current state is "2".
If it is then I've to check if the other ID is on the list of 38 ID-s. And if all that is true then I've to list these occurences.

What I do at the moment:
I've an array for the unique ID-s.

I start from the first row and start checking how many times the task occured (application.worksheetfunction.countif). If its less then 3 then I go to the next row (if its 2 then 2 rows below).

If there is at least 3, then I put all the occurences data in a 2D array. (that could be unnecessary, dunno)
After that I check every item in the array if the other ID is in the ID array list (UBound(filter)) .
If there is a hit, then i'll write the data on the sheet I've to.

(screenupdating and calculation is off)

'... declaring variable and stuff

For i = 2 To LastRow
'Aktual rows unique ID
CurCID = HDRes.Cells(i, 2).Value
'The countid
CIDdb = Application.WorksheetFunction.CountIf(HDRes.Range("B:B"), CurCID)

If CIDdb < 3 Then GoTo nextRW
'populating the array
ReDim CIDArray(1 To CIDdb, 1 To 4)
    For cid = 1 To CIDdb
    CIDArray(cid, 1) = HDRes.Cells(i + (cid - 1), 3) 'employee ID
    CIDArray(cid, 2) = HDRes.Cells(i + (cid - 1), 4) 'state
    CIDArray(cid, 3) = HDRes.Cells(i + (cid - 1), 6) 'other ID
    CIDArray(cid, 4) = HDRes.Cells(i + (cid - 1), 7) 'Date+time
    Next cid
'the first and last state doesn't count so from the 2nd to the last one -1

    For ID = 2 To CIDdb - 1
    If CIDArray(ID, 2) = 2 Then
'checking if the othre ID is in the array list
        If UBound(Filter(HDArray, CIDArray(ID, 3))) >= 0 And CIDArray(ID, 1) < 34000 Then

'finding the employees data
        Set EIDPos = TBD.Range("C:C").Find(What:=CIDArray(ID, 1), LookIn:=xlFormulas, _
        LookAt:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

'finding the first empty row in the result page
        Set LastRow2 = HDSh.Range("A:A").Find(What:="", LookIn:=xlFormulas, _
        LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, _
        MatchCase:=False, SearchFormat:=False)

        HDSh.Cells(LastRow2.Row, 1).Value = Format(CDate(CIDArray(ID, 4)), "YYYY.MM.DD")
        HDSh.Cells(LastRow2.Row, 2).Value = Format(CDate(CIDArray(ID, 4)), "HH:MM:SS")
        HDSh.Cells(LastRow2.Row, 3).Value = TBD.Cells(EIDPos.Row, 2).Value
        HDSh.Cells(LastRow2.Row, 4).Value = TBD.Cells(EIDPos.Row, 1).Value
        HDSh.Cells(LastRow2.Row, 5).Value = TBD.Cells(EIDPos.Row, 3).Value
        HDSh.Cells(LastRow2.Row, 6).Value = TBD.Cells(EIDPos.Row, 4).Value
        HDSh.Cells(LastRow2.Row, 7).Value = HDSh.Cells(LastRow2.Row, 1).Value & _
        Format(HDSh.Cells(LastRow2.Row, 2).Value, "HH:MM:SS") & HDSh.Cells(LastRow2.Row, 6).Value
        HDSh.Cells(LastRow2.Row, 8).Value = CIDArray(ID, 3)
        
       End If

    Else
    GoTo nextID
    End If
 
nextID:
    Next ID
 
nextRW:
i = i + (CIDdb - 1)
 
next i

Thank you,
YvorL