Macro taking a lot of time to execute

[mjosh94]

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 :

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

 

[mohadin]

Hi
Try

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]

Hi again
This one is debugged

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