Sub DivEtImp(Optional ByVal Col As Long = 1, Optional ByVal Del As Boolean = True)

   Dim i As Long, cl As Long, rw As Long
   Dim Dic As Object
   Dim ShNam As String, Bads() As String
   Dim Bad As Variant
    
   Application.ScreenUpdating = False
   Set Dic = CreateObject("Scripting.Dictionary")
   With Worksheets(1)
      cl = .Cells(1, Columns.Count).End(xlToLeft).Column
      rw = .Cells(Rows.Count, Col).End(xlUp).Row
      For i = 2 To .Cells(Rows.Count, Col).End(xlUp).Row
         On Error Resume Next
         Dic.Add Key:=Trim(.Cells(i, Col).Value), Item:=""
      Next i
   End With
   Application.ScreenUpdating = False
   With Dic
      For i = 0 To .Count - 1
         Worksheets(1).Copy after:=Worksheets(Sheets.Count)
         Bads = Array(":", "\", "/", "[", "]", "?", "*")
         ShNam = .Keys()(i)
         For Each Bad In Bads
            ShNam = Replace(ShNam, Bad, " ", 1, -1, vbTextCompare)
         Next Bad
         ActiveSheet.Name = Left(ShNam, 31)
         Cells(1, Col).Copy Destination:=Cells(1, cl + 2)
         Cells(2, cl + 2).Value = .Keys()(i)
         Range(Cells(1, 1), Cells(rw, cl)).AdvancedFilter Action:=xlFilterCopy, criteriarange:=Range(Cells(1, cl + 2), Cells(2, cl + 2)), copytorange:=Cells(1, cl + 4)
         Range(Columns(1), Columns(cl + 3)).Delete
         If Del Then Columns(Col).Delete
         Range(Columns(1), Columns(IIf(Del, cl - 1, cl))).EntireColumn.AutoFit
      Next i
   End With
   Application.ScreenUpdating = True
End Sub