Efficiency issue when looping through each cell

Originally Posted by royUK

Would it be possible to filter the data using AutoFilter?

Possibly, but I do not see an immediate gain from doing that. What are you thinking?

Originally Posted by shg

I think someone would need to see a reasonable amount of (sanitized) data to make a useful suggestion.

I will attach sample data as soon as I can, but it is just a list of numbers on the weekly sheets, being compared to another list with numbers and a start and finish date.

Throughout your code, you do this:

        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

The With statement isn't doing anything. References should be like this:

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

It is indeed sloppy coding.
The sheet is activated though so the code still determines the ranges, so I do not see this having any real impact on the efficiency.

Originally Posted by shg

I think someone would need to see a reasonable amount of (sanitized) data to make a useful suggestion.

I have a small example of how the data in the different sheets look.

Example of the data on one of the weekly sheets
Example of data on the control sheet that each of the records on the weekly sheet is checked against.

Originally Posted by royUK

AutoFilter would be much faster than a Loop

Could you elaborate a little on how that could be done in this example?

If the record is on the control sheet and the dates overlap, i.e. the start date is before the monday of the week of the weekly sheet and the end date is after that monday, the record on the weekly sheet is marked as included.

Cells(Ry, 21) = "i"

and the record is then copied to a third sheet.

    lastrow = Workbooks("Cal.xlsm").Sheets("Records").UsedRange.Rows.Count
        
    Rows(Ry).Copy Destination:= Workbooks("Cal.xlsm").Sheets("Records").Rows(lastrow + 1)

To check all the records and move/mark the included ones are the purpose of this piece of code.

It was suggested that the fastest way was to use arrays, which I have implemented below.

I had to loop through the registry-array as I could not find a (reasonable) way to search it and return the element number.

So I think what I have now works and it is also a lot faster. However, it is now looping through a 100,000 elements for the registry for every record every week (100,000 records a week), which might not be the most efficient...

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 CPRx As Long
   
Dim endcell As Long

Dim lastrow As Long

Dim registry() As Variant
Dim startdate() As Variant
Dim enddate() As Variant

'Range in the registry
endcell = Workbooks("Cal.xlsm").Sheets("Reg").UsedRange.Rows.Count

'define the arrays for the registry
With Workbooks("Cal.xlsm").Sheets("Reg")
registry = Range(Cells(2, 3), Cells(endcell, 3))
startdate = Range(Cells(2, 7), Cells(endcell, 7))
enddate = Range(Cells(2, 8), Cells(endcell, 8))

End With


Dim newrecords() As Variant

'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)



With Workbooks("ARCHIVE.xlsx")
' # 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
'empty or no new rec
Else

'check if only new rec
With Workbooks("ARCHIVE.xlsx")
If Cells(2, 20) = "Check" Then
Rx = oldrecs + 1
Else
Rx = 2
End If

End With



'define the arrays for the records on the weekly sheet
newrecords = Range(Cells(Rx, 6), Cells(totalrecs, 6))

For Ry = 1 To UBound(newrecords)

CPRx = 1


Do Until CPRx = UBound(registry) + 1

If newrecords(Ry, 1) = registry(CPRx, 1) Then
   
   
   
    If monday >= startdate(CPRx, 1) And monday <= enddate(CPRx, 1) Then
    'included
    'mark and copy
   
    Cells((Ry + Rx - 1), 21) = "i"
   
    lastrow = Workbooks("Cal.xlsm").Sheets("Records").UsedRange.Rows.Count
       
    Rows((Ry + Rx - 1)).Copy Destination:=Workbooks("Cal.xlsm").Sheets("Records").Rows(lastrow + 1)
       
    Exit Do
    Else
    End If
    Else
    End If
   
CPRx = CPRx + 1
   
    Loop

Next Ry

'Check the records on the sheet
Range(Cells(Rx, 20), Cells(totalrecs, 20)) = "Check"

Erase newrecords


End If
Next sht

Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True


End Sub