Efficiency issue when looping through each cell

I have a workbook with weekly data for a whole year (100.000+ records per week) that I need to compare to another workbook with 100.000 records and look for overlapping periods.
Each record in the weekly sheet needs to be marked as checked when the comparison has been performed and if there is an overlapping period that needs to be marked as well and the record copied to a whole other sheet.

I have done this by looping through each week checking every new record against the 100.000 records (via find), but this is quite time consuming, so I am wondering if this can’t be done more efficiently. Maybe by using matrixes?

Any help is greatly appreciated.

Sub New_Records_Check()

Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False



Dim sht As Worksheet
Dim yr As Integer
Dim wk As Integer
Dim monday As Date

Dim oldrecs As Long
Dim totalrecs As Long

Dim Rx As Long
Dim Ry As Long
    
Dim startcell As String
Dim endcell As String
Dim FoundNum As Range
Dim NewNum As Variant

Dim lastrow As Long

    
'Loop through all the sheets
For Each sht In Workbooks("ARCHIVE.xlsx").Sheets

sht.Activate

'Date of monday in the week
yr = Mid(sht.Name, 1, 4)
wk = Mid(sht.Name, 5, 2)
monday = WeekStart(wk, yr) ‘calls a function that determines the date


With Workbooks("ARCHIVE.xlsx")
' number of old and new records
oldrecs = Range(Cells(1, 20), Cells(1, 20).End(xlDown)).Rows.Count
totalrecs = Range(Cells(1, 1), Cells(1, 1).End(xlDown)).Rows.Count
End With

If oldrecs = totalrecs Then
'sheet is either empty or has no new records
Else

'check if there is only new records on the sheet
With Workbooks("ARCHIVE.xlsx")
If Cells(2, 20) = "Check" Then
Rx = oldrecs + 1
Else
Rx = 2
End If

End With

'Range in the control registry
startcell = Workbooks("Cal.xlsm").Sheets("control”).Cells(1, 3).Address
endcell = Workbooks("Cal.xlsm").Sheets("control").Cells(1, 3).End(xlDown).Address



For Ry = Rx To totalrecs Step 1

    
    
    With Workbooks("ARKIV.xlsx")
    NewNum = Cells(Ry, 6)
    End With

    
    Do
    

    Set FoundNum = Workbooks("Cal.xlsm").Sheets("control”).Range(startcell, endcell).Find(What:= NewNum)


    If FoundNum Is Nothing Then
    Exit Do
    Else
    
    If monday >= FoundNum.Offset(0, 4) And monday <= FoundNum.Offset(0, 5) Then
    'Check to see if the Monday is between a starting and finishing date
    'ifso: mark and copy
    
    Cells(Ry, 21) = "i"
    
    lastrow = Workbooks("Cal.xlsm").Sheets("Records").UsedRange.Rows.Count
        
    Rows(Ry).Copy Destination:= Workbooks("Cal.xlsm").Sheets("Records").Rows(lastrow + 1)
        
    Exit Do
    Else
    End If
    End If
    
    startcell = FoundNum.Offset(1, 0).Address
    Loop Until FoundNum Is Nothing Or FoundNum.Address = endcell

'Check the record
Cells(Ry, 20) = "Check"

Next Ry





End If
Next sht

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub