Speed Up My Code

[nniedzielski]

Hi guys-

I am running this code on a document with ~ 25,000 rows by66 columns wide. This code right now is taking around 45 seconds to 55 seconds to run, and sometimes I get the (not responding) and it takes over a minute. I was wondering what steps in my code could be adjusted to run faster.
Thank you much,

Sub PrepareWorkbookRevised()
        
    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    
    Dim startTime As Double
    Dim secondsElapsed As Double
    
    startTime = Timer
    
    Sheets("Sheet1").Select
    Rows("1:2").Delete Shift:=xlUp
    Range("A:B,H:H,J:AD,AF:AK,AN:BJ,BL:BN").EntireColumn.Delete
    
    finalrow = Cells(Rows.Count, 1).End(xlUp).Row
    
    For x = 2 To finalrow
    
    If Rows(x).Height <> 30 Then
        Rows(x).RowHeight = 30
    End If
    
    Next x
    
    Cells.Select
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add2 Key:=Range( _
        "A:A"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
        xlSortNormal
    With ActiveWorkbook.Worksheets("Sheet1").Sort
        .SetRange Range("A:J")
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("A:J").RemoveDuplicates Columns:=2, Header:= _
        xlYes
    Selection.AutoFilter
    ActiveSheet.Range("A:J").AutoFilter Field:=3, Criteria1:="Empty"
    Cells.Select
    Selection.Copy
    Sheets("Empty").Select
    Cells.Select
    ActiveSheet.Paste
    Columns("A:A").EntireColumn.AutoFit
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("E:K").EntireColumn.Delete
    Sheets("Sheet1").Select
    ActiveSheet.Range("A:J").AutoFilter Field:=3, Criteria1:= _
        "Outbound"
    Cells.Select
    Selection.Copy
    Sheets("Outbound").Select
    Cells.Select
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Range("D:G,J:J").EntireColumn.Delete
    Sheets("Sheet1").Select
    ActiveSheet.Range("A:J").AutoFilter Field:=3, Criteria1:="Inbound"
    Cells.Select
    Selection.Copy
    Sheets("Inbound").Select
    Cells.Select
    ActiveSheet.Paste
    Cells.Select
    Cells.EntireColumn.AutoFit
    Sheets("Instructions").Select
    
    secondsElapsed = Round(Timer - startTime, 2)
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    
    MsgBox "Run time was " & secondsElapsed & " seconds", vbInformation
        
End Sub

 

[shg]

Low-hanging fruit: Replace the loop with

  Range(Rows(2), Rows(finalrow)).RowHeight = 30

 

[nniedzielski]

that's a good start

 

[nniedzielski]

took it down to 39.77 seconds