Speed up code

[MAButler]

I have put this together using advice and guidence from forums, could any of you have a look at the following code and give advice on speeding it up, or errors.

This has been a learning curve for me, and before i go to the next step i would like some pointers..........

Option Explicit

Sub Test()
Application.ScreenUpdating = False


Workbooks.Open ("C:\Test\Week.xls")
Sheets("Week").Select

Dim shtActive As Worksheet
    
    Set shtActive = ActiveSheet
    With Workbooks.Add.Worksheets(1)
        shtActive.Cells.Copy
        .Range("A1").PasteSpecial xlPasteValues
        Application.DisplayAlerts = False
        Do While .Parent.Sheets.Count > 1
            .Parent.Sheets(.Parent.Sheets.Count).Delete
        Loop
        
    End With

Windows("Week.xls").Close
    
    Application.DisplayAlerts = True
    
    Columns("D:E").Delete
    Columns("B:B").NumberFormat = "0.00"
    Columns("C:F").NumberFormat = "dd/mm/yyyy"
    Columns("G:G").NumberFormat = "0"
    Rows("1:2").Insert Shift:=xlDown
    Columns("F:F").Delete
    Columns("B:F").Cut Destination:=Range("C:G")
    Columns("G:G").Cut Destination:=Range("B:B")
    Columns("B:B").SpecialCells(xlCellTypeBlanks).EntireRow.Delete

Dim LR As Long, Itm As Long, MyCount As Long, vCol As Long
Dim ws As Worksheet, MyArr As Variant, vTitles As String

vCol = 2
Set ws = Sheets("Sheet1")
vTitles = "A1:F1"
LR = ws.Cells(ws.Rows.Count, vCol).End(xlUp).Row

'Get a temporary list of unique values from column A
ws.Columns(vCol).SpecialCells(xlConstants).AdvancedFilter _
Action:=xlFilterCopy, CopyToRange:=ws.Range("EE1"), Unique:=True

'Sort the temporary list
ws.Columns("EE:EE").Sort Key1:=ws.Range("EE2"), _
Order1:=xlAscending, Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal

'Put list into an array for looping
'(values cannot be the result of formulas, must be constants)
MyArr = Application.WorksheetFunction.Transpose(ws.Range("EE1:EE" _
& Rows.Count).SpecialCells(xlCellTypeConstants))

'clear temporary worksheet list
ws.Range("EE:EE").Clear

'Turn on the autofilter, one column only is all that is needed
ws.Range(vTitles).AutoFilter

'Loop through list one value at a time
'The array includes the title cell, so we start at the second value in the array 'In case values are numerical, we convert them to text with ""
For Itm = 2 To UBound(MyArr)
        ws.Range(vTitles).AutoFilter Field:=vCol, Criteria1:=MyArr(Itm) & ""
    
        If Not Evaluate("=ISREF('" & MyArr(Itm) & "'!A1)") Then    'create sheet if needed
            Worksheets.Add(After:=Worksheets(Worksheets.Count)).Name = MyArr(Itm) & ""
        Else                                                      'clear sheet if it exists
            Sheets(MyArr(Itm) & "").Move After:=Sheets(Sheets.Count)
            Sheets(MyArr(Itm) & "").Cells.Clear
        End If
    
        ws.Range("A" & Range(vTitles).Resize(1, 1) _
            .Row & ":A" & LR).EntireRow.Copy Sheets(MyArr(Itm) & "").Range("A1")
        
        ws.Range(vTitles).AutoFilter Field:=vCol
        MyCount = MyCount + Sheets(MyArr(Itm) & "") _
            .Range("A" & Rows.Count).End(xlUp).Row - 1
        'Sheets(MyArr(Itm) & "").Columns.AutoFit

Application.DisplayAlerts = False
    Selection.Subtotal GroupBy:=2, Function:=xlSum, TotalList:=Array(3), _
        Replace:=True, PageBreaks:=True, SummaryBelowData:=True
        
        With Sheets(MyArr(Itm) & "").UsedRange
            .Offset(.Rows.Count - 1, 0).Resize(.Rows.Count - 1, .Columns.Count).Delete
        End With
        Application.DisplayAlerts = True

Sheets(MyArr(Itm) & "").Rows("1:2").Insert Shift:=xlDown
    Sheets(MyArr(Itm) & "").Range("A1").Value = "Non Payment of Account"
    Sheets(MyArr(Itm) & "").Range("A2").Value = "Automated First Registration & Licensing (AFRL) System"
    Sheets(MyArr(Itm) & "").Columns("A:A").Select
    With Selection
        .HorizontalAlignment = xlLeft
        .VerticalAlignment = xlCenter
        .WrapText = False
    End With
    Sheets(MyArr(Itm) & "").Columns("B:F").Select
    With Selection
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
        .WrapText = True
    End With
    Columns("A:F").Select
    With Selection.Font
        .Name = "Times New Roman"
        .FontStyle = "Regular"
        .Size = 12
    End With
    Sheets(MyArr(Itm) & "").Range("A1:f1").MergeCells = True
    Sheets(MyArr(Itm) & "").Range("A2:f2").MergeCells = True
    Sheets(MyArr(Itm) & "").Range("A1:F2").HorizontalAlignment = xlCenter
    Sheets(MyArr(Itm) & "").Cells.RowHeight = 30
    Sheets(MyArr(Itm) & "").Rows("1:3").Font.Bold = True
    Sheets(MyArr(Itm) & "").Columns("A:A").ColumnWidth = 30
    Sheets(MyArr(Itm) & "").Columns("B:C").ColumnWidth = 13
    Sheets(MyArr(Itm) & "").Columns("D:F").ColumnWidth = 12
    Sheets(MyArr(Itm) & "").PageSetup.RightFooter = "Printed &D"
    Sheets(MyArr(Itm) & "").PageSetup.LeftMargin = Application.InchesToPoints(0.19)
    Sheets(MyArr(Itm) & "").PageSetup.RightMargin = Application.InchesToPoints(0.19)
    Sheets(MyArr(Itm) & "").PageSetup.TopMargin = Application.InchesToPoints(0.9)
    Sheets(MyArr(Itm) & "").PageSetup.BottomMargin = Application.InchesToPoints(0.9)
    Sheets(MyArr(Itm) & "").PageSetup.HeaderMargin = Application.InchesToPoints(0.5)
    Sheets(MyArr(Itm) & "").PageSetup.FooterMargin = Application.InchesToPoints(0.5)
    Sheets(MyArr(Itm) & "").PageSetup.CenterHorizontally = True
    
Next Itm

'Cleanup

ws.AutoFilterMode = False

MsgBox "Rows with data: " & (LR - Range(vTitles).Cells(1, 1).Row) _
& vbLf & "Rows copied to other sheets: " _
& MyCount & vbLf & "Hope they match!!"

Application.DisplayAlerts = False
Const DirectoryToSaveIn As String = "C:\Test\"
ActiveWorkbook.SaveAs Filename:=DirectoryToSaveIn & "Payments Chased - " & Format(Date, "dd.mm.yy") & ".xls"
Application.DisplayAlerts = True
Application.ScreenUpdating = True

    Windows("Do Letters.xls").Activate
    ActiveWorkbook.Close
    
End Sub

The next step is to send each sheet to a seperate email address..........

1. Need to learn how to extract email address from another file.....
2. need to learn how to send each sheet as an email....

Thanks