Create new excel files based on the data in a column

Sub CreateNewWbks()

    Dim dic As Object, rng As Range, wks As Worksheet, mypath As String, lr As Long
    Set dic = CreateObject("scripting.dictionary")
    Set wks = Sheet1
    
mypath = ThisWorkbook.Path & "\"
lr = wks.Range("F" & Rows.Count).End(xlUp).Row

Application.ScreenUpdating = False
Application.DisplayAlerts = False

With wks
    
For nr = lr To 2 Step -1
        If (Not dic.exists(.Cells(nr, "F").Value)) Then
        dic.Add .Cells(nr, "F").Value, .Cells(nr, "F").Value
        Set rng = .Range("A1:I" & .Cells(Rows.Count, 1).End(xlUp).Row)
            rng.AutoFilter field:=6, Criteria1:=.Range("F" & nr).Value
            rng.Copy
            Workbooks.Add
            ActiveSheet.Paste
            ActiveSheet.Columns.AutoFit
            ActiveSheet.[A1].Select
            ActiveWorkbook.SaveAs Filename:=mypath & .Range("F" & nr).Value & ".xlsx"
            ActiveWorkbook.Close
        End If
    Next
           .AutoFilterMode = False
End With

MsgBox "All Done!", vbExclamation
Application.CutCopyMode = False
Application.DisplayAlerts = True
Application.ScreenUpdating = True

End Sub