Игорь,нужно кое что другое

отпишитесь кто согласен  

kuklp,можно подробнее

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



есть макрос для копирования таблицы по значениям, но при создании новых листов не сохраняется ширина столбцов из исходной таблицы

kuklp,ну точнее строк

нужно из исходной страницы где имеется таблица отфильтровать по фамильно и каждую добавить в новую страницу