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