Процедура имеет два не обязательных параметра: 1) номер столбца с критериями (могут быть не уникальными; все строки с совпадающим критерием попадают на один лист). Тип — Long. Значение по умолчанию — 1 2) необходимость удаления из полученных листов столбца критерия. Тип — Boolean. Значение по умолчанию — True.
Файл-пример, кроме самой процедуры, содержит макросы test для её вызова и delsh для удаления листов, созданных при предыдущем тесте.
Код 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 |