Code works, but takes far too long

**DanzaNZ** · 10-08-2019, 10:44 PM

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

**jolivanes** · 10-09-2019, 12:40 AM

You could start by cleaning up your code.
Get rid of all the selecting.
This is an example from your code that is not required.

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

Structure your code.
You dimension all through the +/- 200 lines of code instead of at the beginning.
etc etc
I doubt anybody will dig through this mess (forgive me for being non political) and clean it up.
Google is your best friend.
A few examples for you.
https://stackoverflow.com/questions/...t-in-excel-vba
https://www.spreadsheetsmadeeasy.com...akes-to-avoid/
https://powerspreadsheets.com/excel-...sential-terms/
https://source.opennews.org/articles...-spreadsheets/
Most excel gurus have a tutorial on how to structure code also.

**DanzaNZ** · 10-09-2019, 01:14 AM

Thanks!, i really appreciate the tips!

**jolivanes** · 10-09-2019, 01:33 AM

Maybe explain in a "to the point" manner what you want to achieve.
The best approach is usually to ask for one problem to be solved at the time.
It can be sewn together later on.
You will also see how these helpers structure the code.

Another small example.
This

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

can be changed to

Sheets("BPR Calculator").Range("C8").Font.Color = vbRed

You don't need the "TintAndShade" because zero (0) means neutral (no change)

Code works, but takes far too long

LinkBack

Thread Tools

Rate This Thread

Display

Hybrid View

Code works, but takes far too long

Re: Code works, but takes far too long

Re: Code works, but takes far too long

Re: Code works, but takes far too long

Thread Information

Users Browsing this Thread

Similar Threads

[SOLVED] Help with code efficiency - routine takes WAY too long to run

[SOLVED] This code takes way to long to run

[SOLVED] Translate code takes long time

Inefficient code - macro takes too long

Code works but takes hours to run.

Long code takes an age to run

My Code takes too long to execute

Tags for this Thread

Bookmarks

Bookmarks

Posting Permissions