Clean up and Speed Up Code

Hi all,

Wondering if I can call on your skils to help clean up and speed up the code I have managed to cobble together and borrow from all over the internet and other guru's?

Code basically ADDS three columns after the last column and runs three different formulas down a dynamically growing (rows) report and then formats the dataset to freeze the top row, add a filter and borders i.e. make it presentable.

Current number of rows is 24409 and will double incrementally on a daily basis within the next 3-4 months.

Like I say code works just takes ages to run - approx. 4-5 mins or would you say that's normal?

Sub Cost_ReportA()

'turn off some Excel functionality so your code runs faster
Application.ScreenUpdating = False
Application.DisplayStatusBar = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
ActiveSheet.DisplayPageBreaks = False 'note this is a sheet-level setting

If ActiveSheet.AutoFilterMode = True Then
Range("A1").AutoFilter
End If

'Sub CreateNamedRanges()
Dim WB As Workbook, ws As Worksheet
Dim lrow As Long, lcol As Long, i As Long
Dim myName As String, Start As String

Const Rowno = 1
Const Colno = 1
Const offset = 1

On Error Resume Next

Set WB = ActiveWorkbook
Set ws = ActiveSheet

lcol = ws.Cells(Rowno, 1).End(xlToRight).Column
lrow = ws.Cells(Rows.count, Colno).End(xlUp).Row
    Start = Cells(Rowno, Colno).Address
        WB.Names.Add name:="lcol", RefersTo:="=COUNTA($" & Rowno & ":$" & Rowno & ")"
        WB.Names.Add name:="lrow", RefersToR1C1:="=COUNTA(C" & Colno & ")"
        WB.Names.Add name:="myData", RefersTo:="=" & Start & ":INDEX($1:$65536," & "lrow," & "Lcol)"
            For i = Colno To lcol
            myName = Replace(Cells(Rowno, i).value, " ", "_")
            If myName <> "" Then
            WB.Names.Add name:=myName, RefersToR1C1:="=R" & Rowno + offset & "C" & i & ":INDEX(C" & i & ",lrow)"
        End If
    Next

'Add additional Headings at the end of the report
Dim Found As Range
Dim LR As Long

Set Found = Rows(1).Find(what:="Curr_Diff_status", LookIn:=xlValues, LookAt:=xlWhole)
If Found Is Nothing Then Exit Sub
    LR = Cells(Rows.count, Found.Column).End(xlUp).Row
        Found.offset(, 1).EntireColumn.Insert
        Cells(1, Found.Column + 1).value = "Unique_PR"
    Range(Cells(2, Found.Column + 1), Cells(LR, Found.Column + 1)).FormulaR1C1 = "=IF(ISNA(VLOOKUP(PR_ID,R1C1:R[-1]C[-79],1,)),1,0)"
    
Set Found = Rows(1).Find(what:="Curr_Diff_status", LookIn:=xlValues, LookAt:=xlWhole)
If Found Is Nothing Then Exit Sub
    LR = Cells(Rows.count, Found.Column).End(xlUp).Row
        Found.offset(, 2).EntireColumn.Insert
        Cells(1, Found.Column + 2).value = "CatCode"
    Range(Cells(2, Found.Column + 2), Cells(LR, Found.Column + 2)).Formula = "=LEFT(SupplierPartNumber,4)"

Set Found = Rows(1).Find(what:="Curr_Diff_status", LookIn:=xlValues, LookAt:=xlWhole)
If Found Is Nothing Then Exit Sub
    LR = Cells(Rows.count, Found.Column).End(xlUp).Row
        Found.offset(, 3).EntireColumn.Insert
        Cells(1, Found.Column + 3).value = "Resource_Count"
    Range(Cells(2, Found.Column + 3), Cells(LR, Found.Column + 3)).Formula = "=personal.xlsb!WordCounts(RC[-30],"","")"
Calculate

'Convert formulas to values
    ActiveSheet.Cells.Copy
    ActiveSheet.Cells.PasteSpecial Paste:=xlPasteValues

'Sub TheWall()
    With ActiveSheet.UsedRange.Borders
        .LineStyle = xlContinuous
        .Weight = xlHairline
        .ColorIndex = xlAutomatic
    End With
    With ActiveSheet.UsedRange.Cells.Font
        .name = "Calibri"
        .size = 10
        Dim s As Worksheet
    End With

'Format Header Row
    If ActiveSheet.AutoFilterMode = False Then
        With Range(Range("A1"), Range("IV1").End(xlToLeft))
        '.AutoFilter
        .Font.ColorIndex = 2
        .Font.Bold = True
         
        With .Interior
        .ColorIndex = 14
        .Pattern = xlSolid
        End With
        .HorizontalAlignment = xlCenter
        .Columns.Autofit
        
        Sheets("Daily_Cost_Report").Tab.ColorIndex = 24
    End With
 Else
    MsgBox "Cannot autofilter the header row, there is already an autofilter on this sheet", vbCritical
End If
    
ActiveWindow.Zoom = 85

Sheets("Daily_Cost_Report").UsedRange.Select
With Selection
.WrapText = False
End With

'Sub TurnAutoFilterOn()
'check for filter, turn on if none exists
  If Not ActiveSheet.AutoFilterMode Then
    ActiveSheet.Range("A1").AutoFilter
  End If

    Columns("A:A").Select
    With ActiveWindow
        .SplitColumn = 1
        .SplitRow = 0
    End With
    ActiveWindow.FreezePanes = True
    Rows("1:1").Select

    With ActiveWindow
        .SplitColumn = 1
        .SplitRow = 1
    End With
    ActiveWindow.FreezePanes = True

'after your code runs, restore state; put this at the end of your code
Application.ScreenUpdating = screenUpdateState
Application.DisplayStatusBar = statusBarState
Application.Calculation = calcState
Application.EnableEvents = eventsState
ActiveSheet.DisplayPageBreaks = displayPageBreaksState 'note this is a sheet-level setting

Call CopyPasteWithoutClipboard(Sheet1.Range("A1").CurrentRegion, Sheet1.Range("A1"), copyByValue)
Call AutoFitAll

End Sub

Any assistance/tips, etc would be greatly appreciated

Kind regards,