Translating records to right cells based on two criteria

Hello all!

I'm quite new to VBA though I can manage the basics.
I've stumbled on the next issue..

The following code does what I want it to do (translating the record to the rightly positioned Cell in a overview) though it's really slow.

The code:

With Sheets("Database_Ingeroosterd_IN").Activate
LastRow = Cells(Rows.Count, 1).End(xlUp).Row
End With

For Each cell In Sheets("Roosteroverzicht").Range(PersoneelsnrRange)
    With Sheets("Database_Ingeroosterd_IN").Range(Cells(2, 1), Cells(LastRow, 1))
        Set Apenkop = .Find(What:=cell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
        If Not Apenkop Is Nothing Then
            For Each datumcell In Range(Datumrange)
                With Sheets("Database_Ingeroosterd_IN").Range(Cells(2, 8), Cells(LastRow, 8))
                    If datumcell <> "" Then
                    Set Apencombi = .Find(What:=(cell & CLng(datumcell)), After:=.Cells(1), LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByColumns, SearchDirection:=xlPrevious, MatchCase:=False)
                        If Apencombi Is Nothing Then    'CLng omdat de datumwaarde in serie moet
                        GoTo Volgende
                        End If
                        If Apencombi.Offset(0, -7).Value <> Apenkop Then
                            GoTo Volgende
                        End If
                        Sheets("Roosteroverzicht").Range(cell.Address).Offset(0, (datumcell.Column - cell.Column) - 1).Value = Apencombi.Offset(0, -5).Value 'Wachtdienst
                        Sheets("Roosteroverzicht").Range(cell.Address).Offset(0, (datumcell.Column - cell.Column)).Value = Apencombi.Offset(0, -4).Value 'Ochtend
                        If Apencombi.Offset(0, -2).Value <> "" Then
                            Sheets("Roosteroverzicht").Range(cell.Address).Offset(0, (datumcell.Column - cell.Column)).ClearComments
                            Sheets("Roosteroverzicht").Range(cell.Address).Offset(0, (datumcell.Column - cell.Column)).AddComment.Text Text:=Apencombi.Offset(0, -2).Value 'OchtendOpmerking
                        End If
                        Sheets("Roosteroverzicht").Range(cell.Address).Offset(0, (datumcell.Column - cell.Column) + 1).Value = Apencombi.Offset(0, -3).Value 'Middag
                        If Apencombi.Offset(0, -1).Value <> "" Then
                            Sheets("Roosteroverzicht").Range(cell.Address).Offset(0, (datumcell.Column - cell.Column) + 1).ClearComments
                            Sheets("Roosteroverzicht").Range(cell.Address).Offset(0, (datumcell.Column - cell.Column) + 1).AddComment.Text Text:=Apencombi.Offset(0, -1).Value 'Middagopmerking
                        End If
                    Else
                    End If
                End With
Volgende:
            Next
        Else
        End If
    End With
'frmInfoscreen.Label7 = "Regel " & cell.Row & " / " & LastRow
'frmInfoscreen.Repaint
Next

How it works:
It searches for the given personnelnumber from a displaysheet.
Next, it tries to find a match in the recordsheet and if it exists copy the information to the matching date cell.

In the displaysheet:
Verticalle I've stored the personnelnumbers and horizontalle the dates.

The UID from de fieldrecord is based on the personnelnumber combined with the date in Long format.

I sincerely hope someone can give me advice how to speedup this process!

Hi -

If you can attach the actual file then we can help.

Sounds like it can be done in one loop.

Regards,
Event

See my attachment for the example worksheet.

Will do!

Making a blank copy as we speak, deleting sensitive information..

Anyone?

Hi -

See if this makes any difference.

Sub test()
Dim rng()
rng = Range("a5:ed425")
Application.ScreenUpdating = False
Application.EnableEvents = False
rw = 5
Do While rw <= 425
For i = 13 To 133 Step 3
    With Sheets("Database_Ingeroosterd_IN").Columns("h")
        Set c = .Find(Cells(rw, 1) & CLng(Cells(3, i)), , , 1)
            If Not c Is Nothing Then
                rng(rw - 4, i - 1) = c.Offset(, -5).Value
                rng(rw - 4, i) = c.Offset(, -4).Value
                If c.Offset(, -2).Value <> vbNullString Then
                    Cells(rw, i).ClearComments
                    Cells(rw, i).AddComment c.Offset(, -2).Value
                End If
                rng(rw - 4, i + 1) = c.Offset(, -3).Value
                If c.Offset(, -1).Value <> vbNullString Then
                    Cells(rw, i + 1).ClearComments
                    Cells(rw, i + 1).AddComment c.Offset(, -1).Value
                End If
            End If
    End With
Next
rw = rw + 1
Loop
Range("a5:ed425") = rng
Set c = Nothing
Application.EnableEvents = True
Application.ScreenUpdating = True
end sub

Regards,
Event