Macro taking a lot of time to execute

mjosh94

New Member
Joined
Mar 16, 2021
Messages
1
Office Version
  1. 365
Platform
  1. Windows
Hello all !
I am fairly new to MACROS and VBA. Recently I wrote a Macro to segregate data of employees as per their job levels.
Since it is for a fairly big organization the number of rows (employees) of the data is huge.
I made a simple code for copying the title header of the data to new sheets.
Renaming sheets as per Job level and then using IF in the Base data to check which job level the current employee is and then pasting entire row to the specified job level excel sheet.

The program is running fine but it is taking ~ 30 secs. to execute.

I am using the below formula to find the next empty row in the job level sheets.
Range("A1048576").End(xlUp).Offset(1, 0).Select

I think using this is making my macro slow.

Can I use anything else?
What can I do to speed up my macro.

Posting the code below :

VBA Code:
Sub GRADEWISE()
Application.ScreenUpdating = False
Sheets("Sheet1").Activate
Range("A3").Activate
Dim i As Long
i = Application.WorksheetFunction.Count(Range(ActiveCell, ActiveCell.End(xlDown)))
'to count the number of employees

'creating new sheets and copying header row
Sheets.Add(After:=Sheets("Sheet1")).Name = "A1_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("A1_Grade").Rows("2"))

Sheets.Add(After:=Sheets("Sheet1")).Name = "A_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("A_Grade").Rows("2"))

Sheets.Add(After:=Sheets("Sheet1")).Name = "B_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("B_Grade").Rows("2"))

Sheets.Add(After:=Sheets("Sheet1")).Name = "C_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("C_Grade").Rows("2"))

Sheets.Add(After:=Sheets("Sheet1")).Name = "D_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("D_Grade").Rows("2"))

Sheets.Add(After:=Sheets("Sheet1")).Name = "E_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("E_Grade").Rows("2"))

Sheets.Add(After:=Sheets("Sheet1")).Name = "F_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("F_Grade").Rows("2"))

Sheets.Add(After:=Sheets("Sheet1")).Name = "G_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("G_Grade").Rows("2"))

Sheets.Add(After:=Sheets("Sheet1")).Name = "H_Grade"
Sheets("Sheet1").Rows("2").Copy (Sheets("H_Grade").Rows("2"))



Sheet1.Activate




For x = 3 To i

Range("A" & x).Activate

If Cells(x, 18) = "AH" Then

ActiveCell.EntireRow.Copy
Sheets("H_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

ElseIf Cells(x, 18) = "AG" Then


ActiveCell.EntireRow.Copy
Sheets("G_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

ElseIf Cells(x, 18) = "AF" Then

ActiveCell.EntireRow.Copy
Sheets("F_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

ElseIf Cells(x, 18) = "AE" Then

ActiveCell.EntireRow.Copy
Sheets("E_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

ElseIf Cells(x, 18) = "AD" Then

ActiveCell.EntireRow.Copy
Sheets("D_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

ElseIf Cells(x, 18) = "AC" Then

ActiveCell.EntireRow.Copy
Sheets("C_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

ElseIf Cells(x, 18) = "AB" Then

ActiveCell.EntireRow.Copy
Sheets("B_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

ElseIf Cells(x, 18) = "AA" Then

ActiveCell.EntireRow.Copy
Sheets("A_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste

ElseIf Cells(x, 18) = "A1" Then

ActiveCell.EntireRow.Copy
Sheets("A1_Grade").Select
Range("A1048576").End(xlUp).Offset(1, 0).Select
ActiveSheet.Paste


End If


Sheet1.Activate



Next x




End Sub
 
Last edited by a moderator:

Excel Facts

How to show all formulas in Excel?
Press Ctrl+` to show all formulas. Press it again to toggle back to numbers. The grave accent is often under the tilde on US keyboards.

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,091
Office Version
  1. 2013
Platform
  1. Windows
Hi
Try
VBA Code:
Sub GRADEWISE()
    Dim i, ii As Long
    Dim a, NEWSH, Filt As Variant
    Application.ScreenUpdating = False
    Sheets("Sheet1").Activate
    NEWSH = Array("A1_Grade", "A_Grade", "B_Grade", "C_Grade", "D_Grade", "E_Grade", "F_Grade", "G_Grade", "H_Grade")
    Filt = Array("A1", "AA", "AB", "AC", "AD", "AE", "AF", "AG", , "AH")
    For ii = 1 To UBound(NEWSH)
        Sheets.Add(After:=Sheets("Sheet1")).Name = NEWSH(ii)
        With Sheets("sheet1")
            .Range("A2:N2").AutoFilter
            .Range("$A$2:$N$35").AutoFilter Field:=1, Criteria1:=Filt(ii)
            .Range("$A$2:$N$35").SpecialCells(12).Copy Sheets(NEWSH(ii)).Cells(2, 1)
        End With
    Next
End Sub
 

mohadin

Well-known Member
Joined
Mar 22, 2015
Messages
1,091
Office Version
  1. 2013
Platform
  1. Windows
Hi again
This one is debugged
VBA Code:
Sub GRADEWISE()
    Dim lr, ii As Long
    Dim a, NEWSH, Filt As Variant
    Dim rng As Range
    Application.ScreenUpdating = False
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    NEWSH = Array("A1_Grade", "A_Grade", "B_Grade", "C_Grade", "D_Grade", "E_Grade", "F_Grade", "G_Grade", "H_Grade")
    Filt = Array("A1", "AA", "AB", "AC", "AD", "AE", "AF", "AG", "AH")
    For ii = 0 To UBound(NEWSH)
        Sheets.Add.Name = NEWSH(ii)
        With Sheets("sheet1").Range("A2:N2")    ' << Change as your requierment
            .Resize(lr).AutoFilter Field:=1, Criteria1:=Filt(ii)
            .Resize(lr).SpecialCells(12).Copy Sheets(NEWSH(ii)).Cells(2, 1)
        End With
    Next
    Sheets("sheet1").Range("A2:N2").AutoFilter    ' << Change as  above
    Sheets("sheet1").Select
    Application.ScreenUpdating = False
End Sub
 

Watch MrExcel Video

Forum statistics

Threads
1,129,931
Messages
5,639,064
Members
417,067
Latest member
rohitbabshet

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top