Slava977,
На листе Данные создайте кнопку и привяжите к ней макрос.
Макрос в стандартный модуль
| Код |
|---|
Sub iFilter()
Dim i As Long
Dim n As Integer
Dim Criterij As String
Dim iName As String
Dim Sht As Worksheet
Dim Sht_table As String
Dim iLastCol As Integer
Dim iSelectCol As Integer
Dim iLastRow As Long
Application.ScreenUpdating = False
Application.DisplayAlerts = False 'отключение предупреждающих сообщений
Sht_table = ActiveSheet.Name
For Each Sht In ThisWorkbook.Worksheets 'удаляем все листы, кроме Sht_table
If Sht.Name <> Sht_table Then Sht.Delete
Next
Application.DisplayAlerts = True
iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column 'последний столбец
Set Sht = ThisWorkbook.Worksheets(Sht_table)
iLastRow = Cells(Rows.Count, 1).End(xlUp).Row
Columns(iLastCol + 2).Clear
Range("A1:A" & iLastRow).AdvancedFilter Action:=xlFilterCopy _
, CopyToRange:=Cells(1, iLastCol + 2), Unique:=True
n = Cells(Rows.Count, iLastCol + 2).End(xlUp).Row
For i = 2 To n 'цикл по уникальным значениям столбца A
Criterij = Sht.Cells(i, iLastCol + 2)
iName = Criterij 'имя нового листа
Sht.Range(Sht.Cells(1, 1), Sht.Cells(iLastRow, iLastCol)).AutoFilter 1, Criterij
Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
With Worksheets.Add(After:=Worksheets(Worksheets.Count)) 'добавляет новый лист в конец
.Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteColumnWidths
.Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteFormats
.Range(Cells(1, 1), Cells(1, iLastCol)).PasteSpecial xlPasteValues
Sht.AutoFilter.Range.AutoFilter
.Name = iName
.Range("A1").Select
End With
Next
Application.ScreenUpdating = True
Sht.Activate
Columns(iLastCol + 2).Clear
End Sub
|
