Выбрать дату в календареВыбрать дату в календаре

Страницы: 1
написание макроса для печати по шаблонам
 
отпишитесь кто согласен  
Изменено: mrco - 13.04.2016 08:56:28
сохранение ширина столбцов
 
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



есть макрос для копирования таблицы по значениям, но при создании новых листов не сохраняется ширина столбцов из исходной таблицы
фильтр столбцов и добавление их в новые страницы
 
нужно из исходной страницы где имеется таблица отфильтровать по фамильно и каждую добавить в новую страницу
Страницы: 1
Наверх