Домашняя страница Undo Do Save Карта сайта Обратная связь Поиск по форуму
МИР MS EXCEL - Гость.xls

Вход

Регистрация

Напомнить пароль

 

= Мир MS Excel/Готовые решения

МЕНЮ САЙТА
  • 1
  • 2
  • 3

КАТЕГОРИИ РАЗДЕЛА

ОПРОСЫ
Какой версией Excel Вы пользуетесь?
Всего ответов: 54706
Главная » Готовые решения » VBA » Процедуры

Разделение таблицы по листам по критерию
06.09.2018, 16:54
[ Файл-пример (19.2 Kb) ]

Процедура разделяет таблицу с заголовками на листы по критериям, содержащимся в одном из столбцов. Имя листа совпадает с критерием.

Процедура имеет два не обязательных параметра:

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
Добавил: StoTisteg | | Теги: Разделение таблиц, ВБА, vba
Просмотров: 1942 | Рейтинг: 4.5/2
Всего комментариев: 0
Добавлять комментарии могут только зарегистрированные пользователи.
[ Регистрация | Вход ]
Яндекс.Метрика Яндекс цитирования
© 2010-2022 · Дизайн: MichaelCH · Хостинг от uCoz · При использовании материалов сайта, ссылка на www.excelworld.ru обязательна!