Sub wer()
Dim cell, r As Range, ws, a, i&, sh As Worksheet
On Error Resume Next
n = ActiveSheet.Name
For Each cell In Worksheets(n).Range("C2:C100")
If cell.Value <> Empty Then
Set ws = Worksheets.Add(after:=Sheets
(ThisWorkbook.Sheets.Count))
ws.Name = CStr(cell.Value)
ws.Move Before:=Worksheets(n)
End If
Next
Set r = [a2].CurrentRegion: a = r.Value
With CreateObject("scripting.dictionary")
For i = 3 To UBound(a)
If Not .exists(a(i, 3)) Then
.Item(a(i, 3)) = ""
Set ws = Worksheets.Add(after:=Sheets
(ThisWorkbook.Sheets.Count))
ws.Name = a(i, 3)
r.Cells(1).Resize(2, 10).Copy ws.[a1]
r.AutoFilter 3, a(i, 3)
r.Offset(2).Columns(1).Resize(, 10).SpecialCells
(12).Copy ws.[a3] '.
r.AutoFilter
End If
Me.Activate
Next
Me.AutoFilterMode = 0
End With
Exit Sub
ErrorHandler:
MsgBox Error, vbExclamation + vbOKOnly
End Sub
есть макрос для копирования таблицы по значениям, но при создании новых листов не сохраняется ширина столбцов из исходной таблицы
