Hi all

This might be a long shot, but I am stuck for a quicker solution.....

Can someone help me with my code please? it currently takes two hours to run, or it crashes excel

Here are the summary points of what it does:
- Adds and re-names a new sheet for each row in the range
- Filters and copies results of each row (being employee number) to the newly created sheet
- Finds the most recent row for each employee position title by deleting the others (row by row, using the: 'if x = x.offest = x'
- Apply formulas to cells

I REALLY HOPE SOMEONE CAN GIVE ANY BIT OF HELP, EVEN IF IT'S TO CHANGE ONLY ONE PART!

Thanks in advance!

Sub P2_Main_Calc()
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False


Sheets("BPR Calculator").Range("C8").Value = "running..."
Sheets("BPR Calculator").Select
Range("C8").Select
With Selection.Font
    .Color = -16776961
    .TintAndShade = 0
End With

Sheets("BPR Calculator").Select
Dim i As Long, Lrow1 As Long, Lrow2 As Long
COUNTER = 0
Lrow1 = Sheets("BPR Calculator").Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
If Sheet3.AutoFilterMode Then Sheet3.AutoFilterMode = False
COUNTER_of_Processed_Employees = Lrow1 - 14
Lrow2 = Sheets("ETD Emp Trans Data").Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    
Sheets("BPR Calculator").Select
For Each EMPLOYEE_NUMBER In Sheets("BPR Calculator").Range("A15:A" & Lrow1)
    Application.ScreenUpdating = False
    Sheets("BPR Calculator").Select
    'MsgBox (EMPLOYEE_NUMBER)
    Application.ScreenUpdating = True
    COUNTER = COUNTER + 1
    Sheets("BPR Calculator").Range("D8").Value = COUNTER & " employees processed"
    Application.ScreenUpdating = False
    
    '**************************Add sheet for an employee************************************************************
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "Temp" & EMPLOYEE_NUMBER
    Sheets("BPR Calculator").Activate

    
    With Worksheets("ETD Emp Trans Data").Range("$A$1:$R$" & Lrow2)
        .AutoFilter field:=1, Criteria1:="" & strSearch & EMPLOYEE_NUMBER
        .Copy Destination:=Sheets("Temp" & EMPLOYEE_NUMBER).Range("A1")
    End With
    '***************************************************************************************************************
    
    '**************************Seperating Agreements from Emp history***********************************************
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "EMP_EBA_2"
    Sheets.Add(After:=Sheets(Sheets.Count)).Name = "EMP_Colate"
    '***************************************************************************************************************
    
    '*************************************FINDING LAST ROW**********************************************************
    Dim Lrow3 As Long
    Lrow3 = Sheets("Temp" & EMPLOYEE_NUMBER).Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    '***************************************************************************************************************
    
    '**************************Copying employee data to EMP_Colate sheet********************************************
    Sheets("EMP_Colate").Range("A1:R" & Lrow3).Value = Sheets("Temp" & EMPLOYEE_NUMBER).Range("A1:R1" & Lrow3).Value
    '****************************************************************
    
    '**************************************FINDING LAST ROW'********************************************************
    Dim Lrow4 As Long
    Lrow4 = Sheets("EMP_Colate").Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    '***************************************************************************************************************
    
    '**************************Sorting date in Colate sheet to oldest to newest*************************************
    Dim StRw As Integer, EndRw As Integer
    StRw = 1 ' Starting Row
    EndRw = Range("R" & Lrow4).End(xlUp).Row
    Rows(StRw & ":" & EndRw).Select
    Selection.Sort Key1:=Range("I1"), Order1:=xlAscending
    '***************************************************************************************************************
    
    '**************************FINDING LAST ROW*********************************************************************
    Dim Lrow5 As Long
    Lrow5 = Sheets("EMP_Colate").Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    '***************************************************************************************************************
    
    '**************************Remove RETRO to identify current agreement change dates******************************
    
    Dim c As Range, SrchRng
    Set SrchRng = ActiveSheet.Range("K2", ActiveSheet.Range("K2" & Lrow5).End(xlUp))
    If c Is Nothing Then
        Do
        Set c = SrchRng.Find("Retro", LookIn:=xlValues)
        If Not c Is Nothing Then c.EntireRow.Delete
        Loop While Not c Is Nothing
    Else:
    MsgBox ("Test")
    End If
    '***************************************************************************************************************
    
    Sheets("EMP_Colate").Select
    Range("A1").Select
    Selection.AutoFilter
    ActiveWorkbook.Worksheets("EMP_Colate").AutoFilter.Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("EMP_Colate").AutoFilter.Sort.SortFields.Add Key:= _
        Range("H1:H" & Lrow5), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption _
        :=xlSortNormal
    With ActiveWorkbook.Worksheets("EMP_Colate").AutoFilter.Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    
    '**************************Keeping just the first row that agreement was paid in********************************
    Sheets("EMP_Colate").Select
    Dim Lrow6 As Long
    Lrow6 = Sheets("EMP_Colate").Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    
    ActiveSheet.Range("$A$1:$R" & Lrow6).RemoveDuplicates Columns:=Array(7, 18), _
        Header:=xlYes
        
    '***************************************************************************************************************
    
    '**************************FINDING LAST ROW*********************************************************************
    Dim Lrow7 As Long
    Lrow7 = Sheets("EMP_Colate").Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    '***************************************************************************************************************
    
    '**************************Remove Duplicates********************************************************************
    Sheets("EMP_Colate").Range("$A$1:$R$" & Lrow6).RemoveDuplicates Columns:=18, Header:= _
    xlYes
    '***************************************************************************************************************
    
    '**************************FINDING LAST ROW*********************************************************************
    Dim Lrow8 As Long
    Lrow8 = Sheets("EMP_Colate").Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    '***************************************************************************************************************

    '**************************Apply concatination in COLATE SHEET the copy and paste values************************
    For Each agreement_line In Range("S2:S" & Lrow8)
        agreement_line.Activate
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "=RC[-10]&RC[-1]&RC[-12]&RC[-8]&RC[-7]&RC[-11]"
    Next
    Sheets("EMP_Colate").Columns(19).Copy
    Sheets("EMP_Colate").Columns(19).PasteSpecial xlPasteValues
    Sheets("EMP_Colate").Range("A:R").Delete
    Sheets("EMP_Colate").Range("A1").Value = "HEADER"
    '***************************************************************************************************************
    
     '**************************FINDING LAST ROW*********************************************************************
    Dim Lrow9 As Long
    Lrow9 = Sheets("Temp" & EMPLOYEE_NUMBER).Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    '***************************************************************************************************************

    '**************************Apply concatination in EMPLOYEE SHEET the copy and paste values**********************
    Sheets("Temp" & EMPLOYEE_NUMBER).Select
    For Each agreement_line In Range("S2:S" & Lrow9)
        agreement_line.Activate
        Application.CutCopyMode = False
        ActiveCell.FormulaR1C1 = "=RC[-10]&RC[-1]&RC[-12]&RC[-8]&RC[-7]&RC[-11]"
    Next
    Sheets("Temp" & EMPLOYEE_NUMBER).Columns(19).Copy
    Sheets("Temp" & EMPLOYEE_NUMBER).Columns(19).PasteSpecial xlPasteValues
    '***************************************************************************************************************
    
    '************************Apply formuals to cells******************************************************************
    Dim x As Integer
    Application.ScreenUpdating = False
    Sheets("EMP_Colate").Select
    NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count - 1
    Range("A1").Select
    For x = 1 To NumRows
        ActiveCell.Offset(1, 0).Select
        Current_line = ActiveCell
        Sheets("Temp" & EMPLOYEE_NUMBER).Select
        Lrow9 = Range("A1", Range("A1").End(xlDown)).Rows.Count
        Range("A1").Select
        Selection.AutoFilter
        Selection.End(xlToRight).Select
        ActiveSheet.Range("$A$1:$S$" & Lrow9).AutoFilter field:=19, Criteria1:=Current_line
        Range("A1:R" & Lrow9).Select
        Range("R1").Activate
        Selection.Copy
        Sheets("EMP_EBA_2").Select
        ActiveSheet.Paste
        
        Sheets("EMP_EBA_2").Select
        Range("S1").FormulaR1C1 = "Parse_1"
        Range("S2").FormulaR1C1 = "=RIGHT(RC[-11],2)"
        Range("T2").FormulaR1C1 = "Lookup1"
        Range("T2").FormulaR1C1 = "=(IFERROR(VLOOKUP(RC[-1],Pay_Code!C[-19]:C[-18],2,FALSE),0))"
        
        Range("U1").FormulaR1C1 = "Parse_2"
        Range("U2").FormulaR1C1 = "=LEFT(RC[-13],7)"
        Range("W1").FormulaR1C1 = "Start_Date"
        

        If Range("T2").Value = "Weekly" Then Range("W2").FormulaR1C1 = "=(IFERROR(VLOOKUP(RC[-2],Pay_Code!RC[-18]:R[468]C[-14],4,FALSE),0))"
        If Range("T2").Value = "Fortnightly" Then Range("W2").FormulaR1C1 = "=(IFERROR(VLOOKUP(RC[-2],Pay_Code!RC[-12]:R[182]C[-8],4,FALSE),0))"
        If Range("T2").Value = "Monthly" Then Range("W2").FormulaR1C1 = "=(IFERROR(VLOOKUP(RC[-2],Pay_Code!RC[-6]:R[84]C[-2],4,FALSE),0))"
        If Range("T2").Value = "" Then Range("W2").FormulaR1C1 = "=(IFERROR(VLOOKUP(RC[-2],Pay_Code!RC[-6]:R[84]C[-2],4,FALSE),0))"
            
                
        Range("X1").FormulaR1C1 = "End_Date"
        If Range("T2").Value = "Weekly" Then Range("X2").FormulaR1C1 = "=VLOOKUP(RC[-3],Pay_Code!RC[-19]:R[468]C[-15],5,FALSE)"
        If Range("T2").Value = "Fortnightly" Then Range("X2").FormulaR1C1 = "=VLOOKUP(RC[-3],Pay_Code!RC[-13]:R[182]C[-9],5,FALSE)"
        If Range("T2").Value = "Monthly" Then Range("X2").FormulaR1C1 = "=VLOOKUP(RC[-3],Pay_Code!RC[-7]:R[84]C[-3],5,FALSE)"
            
        Range("A2").Select
        Range("A2,B2,C2,F2,G2,W2,Q2,R2").Select
        Selection.Copy
        Sheets("Employee_Check").Select
        NextRow = Range("A" & Rows.Count).End(xlUp).Row + 1
        Range("A" & NextRow).Select
        Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
        Columns("H:H").Select
        Selection.NumberFormat = "dd/mm/yyyy"
        
        Sheets("Temp" & EMPLOYEE_NUMBER).Select
        Range("A1").Select
        Selection.AutoFilter
            
        Sheets("EMP_EBA_2").Select
        Range("A1").Select
        Sheets("Employee_Check").Select
        Range("A1").Select
        Sheets("Temp" & EMPLOYEE_NUMBER).Select
        Range("A1").Select
        Sheets("EMP_Colate").Select
    Next
    '******************************************************************************************************************************
    
    '******Delete the EBA and Colate sheets****************************************************************************************
    Dim ws1 As Worksheet
    Dim ws2 As Worksheet
    Set ws1 = Worksheets("EMP_EBA_2")
    Set ws2 = Worksheets("EMP_Colate")
    Application.DisplayAlerts = False
    ws1.Delete
    ws2.Delete
    Application.DisplayAlerts = True
    '*******************************************************************************************************************************
    
     '**************************FINDING LAST ROW*********************************************************************
    Dim Lrow10 As Long
    Lrow10 = Sheets("Employee_Check").Cells.Find("*", Range("A1"), , , xlByRows, xlPrevious).Row
    '***************************************************************************************************************
    
    '******Applying first Incr Date on the Check Sheet
    Sheets("Employee_Check").Select
    For Each c In Range("H10:H" & Lrow10)
        c.Activate
        c.Offset(0, 1).Value = "=IF(RC[-1]>R5C[-7],RC[-1],R5C[-7])"
        c.Offset(0, 2).Value = "=DATE(YEAR(RC[-1]),MONTH(RC[-1])+R7C[-8],DAY(RC[-1]))"
    Next
    Application.ScreenUpdating = True
    Sheets("BPR Calculator").Shapes("OnSheet_Command_P2").Visible = msoFalse
    Sheets("BPR Calculator").Range("D8").Value = COUNTER & " employees processed"
    Sheets("BPR Calculator").Select
    'Application.Wait (Now + TimeValue("00:00:01"))
    
            
Next

    Sheets("BPR Calculator").Range("C8").Value = "Finished!"
    Sheets("BPR Calculator").Select
    Range("C8").Select
    With Selection.Font
        .Color = -11489280
        .TintAndShade = 0
    End With
    


Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.DisplayStatusBar = True
Application.EnableEvents = True
ActiveSheet.DisplayPageBreaks = True


End Sub