Improving Macro Efficiency - taking hours to run

Hello

I built this macro in the attached sample book through research and it works, however it is very very very slow.

The sample data has only 500 rows and it takes 47s or so to run across 1 day.

Where as actual data has 4000+ rows with across multiple days = hours!


What the Macro is currently doing:
Compare Column P and Q on the "Data" sheet with the Date in Column A on the "TOTAL" and if the "Data" dates fall into that range, copy AT:BF into the TOTALs sheet.
It increments the numbers on TOTAL each time it finds a matching date for every minute.

Note:
I had issues comparing the dates, hence more variables to extract the hour and minute and reconstruct it. Which worked..


Any advice on speeding this up please?
I am flexible in the layout of Totals sheets, i.e alternatively have dates going across the top with time going down to compare against



Full Macro:

Option Explicit
Public Declare PtrSafe Function GetTickCount Lib "kernel32.dll" () As Long

Sub PopulateTotalSheet()
    
    Dim rng, rng2, cell, cell2 As Range
    Dim lrow5, lrow52, UsersAffected, Timer1 As Long
    Dim TotalStartDate, TotalStartTime, TotalStartDateTime, CiStartDay, CiStartTime, CiStartDateTime As Date
    Dim CiEndDay, CiEndtime, CiEndDateTime, CiTemp As Date
    Dim DataWS, TotalWS As Worksheet
    Dim i, e As Integer
    
    Timer1 = GetTickCount
    
    Set DataWS = ThisWorkbook.Sheets("Data")
    Set TotalWS = ThisWorkbook.Sheets("Total")
    
   
    lrow5 = TotalWS.Cells(Rows.Count, 1).End(xlUp).Row
    lrow52 = DataWS.Cells(Rows.Count, 1).End(xlUp).Row
    
    Set rng = TotalWS.Range(Cells(3, 1).Address, TotalWS.Cells(lrow5, 1).Address)
    
    Set rng2 = DataWS.Range(Cells(2, 16).Address, DataWS.Cells(lrow52, 16).Address)
    
    For Each cell2 In rng2
        
        On Error Resume Next
        
        CiTemp = DataWS.Range("Q" & cell2.Row).Value
        
        If Not IsEmpty(cell2.Value) And cell2.Value <> "" And CiTemp > 1 Then
            
            CiStartDay = Int(cell2.Value)
            CiStartTime = TimeSerial(Hour(cell2.Value), Minute(cell2.Value), 0)
            CiStartDateTime = CiStartDay + CiStartTime
            
            CiEndDay = Int(CiTemp)
            CiEndtime = TimeSerial(Hour(CiTemp), Minute(CiTemp), 0)
            CiEndDateTime = CiEndDay + CiEndtime
            
            For Each cell In rng
                
                e = 2
                UsersAffected = 0
                
                TotalStartDate = Int(TotalWS.Range(Cells(cell.Row, 1).Address).Value2)
                
                TotalStartTime = TotalWS.Range(Cells(cell.Row, 1).Address).Value2 - TotalStartDate
                
                TotalStartTime = TimeSerial(Hour(TotalStartTime), Minute(TotalStartTime), 0)
                
                TotalStartDateTime = TotalStartDate + TotalStartTime
                
                If TotalStartDateTime >= CiStartDateTime And TotalStartDateTime <= CiEndDateTime Then
                    
                    For i = 46 To 58
                        
                        UsersAffected = ThisWorkbook.Sheets("Data").Range(Cells(cell2.Row, i).Address).Value + TotalWS.Range(Cells(cell.Row, e).Address).Value2 + UsersAffected
                        
                        TotalWS.Range(Cells(cell.Row, e).Address).Value2 = UsersAffected
                        
                        e = e + 1
                        UsersAffected = 0
                        
                    Next i
                    
                Else
                    
                End If
                
            Next cell
            
        End If
        
    Next cell2
    
    MsgBox "Completed in: " & (GetTickCount - Timer1) / 1000, , "Seconds"
    
End Sub