How to streamline?

[sachavez]

This code takes about 30-seconds to run. I feel like it should take about a second. Is there a more-effective way to do this? Thanks in advance!

Sub Fcst()
'
    Application.ScreenUpdating = False
   
    Sheets.Add.Name = "2024"
    Sheets.Add.Name = "2023"
    Sheets.Add.Name = "2022"
    Sheets("FCST Report").Move after:=Sheets("FCST")
    Sheets("2022").Move after:=Sheets("FCST Report")
    Sheets("2023").Move after:=Sheets("2022")
    Sheets("2024").Move after:=Sheets("2023")
   
    Sheets("FCST").Select
    Range("A3").Select
    ActiveSheet.Range("$A$3:$BB$5000").AutoFilter Field:=3, Criteria1:="2022"
    Range("A3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Selection.Copy
    Sheets("2022").Range("A1").PasteSpecial xlPasteValues
   
   
    ActiveSheet.Range("$A$3:$BB$5000").AutoFilter Field:=3, Criteria1:="2023"
    Range("A3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("2023").Range("A1").PasteSpecial xlPasteValues
   
   
    ActiveSheet.Range("$A$3:$BB$5000").AutoFilter Field:=3, Criteria1:="2024"
    Range("A3").Select
    Range(Selection, Selection.End(xlDown)).Select
    Range(Selection, Selection.End(xlToRight)).Select
    Application.CutCopyMode = False
    Selection.Copy
    Sheets("2024").Range("A1").PasteSpecial xlPasteValues
    ActiveWorkbook.Save
    Range("A3").Select
    ActiveSheet.Range("$A$3:$BB$5000").AutoFilter Field:=3
    'Sheets(Array("2022", "2023", "2024")).Columns.AutoFit
   
    Application.CutCopyMode = False
    Application.ScreenUpdating = True
   
End Sub

 

[Michael M]

Untested, but will be a starting point

Sub Fcst()
Dim lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    Sheets.Add.Name = "2024"
    Sheets.Add.Name = "2023"
    Sheets.Add.Name = "2022"
    Sheets("FCST Report").Move after:=Sheets("FCST")
    Sheets("2022").Move after:=Sheets("FCST Report")
    Sheets("2023").Move after:=Sheets("2022")
    Sheets("2024").Move after:=Sheets("2023")
     With Sheets("FCST")
         .Range("$A$3:$BB" & lr).AutoFilter Field:=3, Criteria1:="2022"
        .UsedRange.Copy Sheets("2022").Range("A1")
        .Range("$A$3:$BB" & lr).AutoFilter Field:=3, Criteria1:="2023"
        .UsedRange.Copy Sheets("2023").Range("A1")
        .Range("$A$3:$BB" & lr).AutoFilter Field:=3, Criteria1:="2024"
        .UsedRange.Copy Sheets("2024").Range("A1")
        .AutoFilter
    End With
    With Sheets(Array("2022", "2023", "2024"))
        With UsedRange
            .Value = .Value
        End With
    End With
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
End Sub

 

[sachavez]

Untested, but will be a starting point

Sub Fcst()
Dim lr As Long
lr = Cells(Rows.Count, "A").End(xlUp).Row
    Application.ScreenUpdating = False
    Sheets.Add.Name = "2024"
    Sheets.Add.Name = "2023"
    Sheets.Add.Name = "2022"
    Sheets("FCST Report").Move after:=Sheets("FCST")
    Sheets("2022").Move after:=Sheets("FCST Report")
    Sheets("2023").Move after:=Sheets("2022")
    Sheets("2024").Move after:=Sheets("2023")
     With Sheets("FCST")
         .Range("$A$3:$BB" & lr).AutoFilter Field:=3, Criteria1:="2022"
        .UsedRange.Copy Sheets("2022").Range("A1")
        .Range("$A$3:$BB" & lr).AutoFilter Field:=3, Criteria1:="2023"
        .UsedRange.Copy Sheets("2023").Range("A1")
        .Range("$A$3:$BB" & lr).AutoFilter Field:=3, Criteria1:="2024"
        .UsedRange.Copy Sheets("2024").Range("A1")
        .AutoFilter
    End With
    With Sheets(Array("2022", "2023", "2024"))
        With UsedRange
            .Value = .Value
        End With
    End With
    ActiveWorkbook.Save
    Application.ScreenUpdating = True
End Sub

Thank you. Ran into a few snags, but fixed. Takes about the same amount of time to run. I'm even working on 64bit.