Private Sub Worksheet_Change(ByVal Target As Range)
Dim d As Object, w As Worksheet, i&, x$
Set d = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
Application.DisplayAlerts = False
For Each w In Worksheets
If Len(w.Name) = 3 Then w.Delete
Next w
With [A1].CurrentRegion
For i = 2 To .Rows.Count
x = .Cells(i, 4)
If Not d.exists(x) Then
d(x) = ""
Sheets.Add After:=Sheets(Sheets.Count)
ActiveSheet.Name = x
.AutoFilter 4, x
.Copy ActiveSheet.[A1]
.AutoFilter
End If
Next i
.Parent.Activate
End With
End Sub