Страницы: 1
RSS
Макрос копирующий данные на новые листы по условию
 
Здравствуйте.
Задача: в общей таблице на листе '1'! есть данные по множеству подразделений, наименование подразделений в столбце G:G. Нужно чтобы макрос в этой же или новой книге (как удобней и проще реализовать) скопировал на новые листы данные столбцов F:F, G:G, H:H, I:I, по условию - наименованию подразделения из столбца G:G.
Как будто, ты в ручную выбрал через фильтр подразделение в столбце G:G, и сам скопировал эти 4 столбца на новый лист.  
Может быть это можно реализовать через отдельный лист справочник, или машина сама отличит уникальные значения в столбце G:G.
 
zvolkz,
попробуйте записать данный макрос
 
evgeniygeo, записать через запись макроса?
 
zvolkz,
да, все верно.
В таком случае, на 80% Ваша задача будет решена
 
скопируйте этот
Код
Sub SplitByDepartment()
  Dim rg As Range, r&, c&
  Set rg = [f2].CurrentRegion: SortRangeBy rg, Array(2)
  Set rg = Intersect([g:i], ActiveSheet.UsedRange)
  r = 4
  Do While Not IsEmpty(rg.Cells(r, 1))
    c = WorksheetFunction.CountIf(rg.Columns(1), rg.Cells(r, 1))
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = rg.Cells(r, 1)
    rg.Rows(2).Copy [a1]: rg.Rows(r).Resize(c).Copy [a2]: r = r + c
  Loop
End Sub


'******************************************************************************
' Сортировка диапазона rg
' по массиву №№ колонок c (Внимание!!! №№ колонок не на листе! а в диапазоне)
' (если № колонки отрицательный - сортировка по убыванию (от старших)
' Hd наличие заголовка 1 или 0 (по умолчанию заголовок ЕСТЬ)
'
Sub SortRangeBy(rg As Range, c, Optional Hd& = 1)
  Dim i&
  With rg.Parent.Sort
    .SortFields.Clear
    For i = LBound(c) To UBound(c)
      .SortFields.Add Key:=rg.Cells(1).Offset(Hd, Abs(c(i)) - 1).Resize( _
      rg.Rows.Count - Hd, 1), SortOn:=xlSortOnValues, Order:=IIf(c(i) > 0, _
      1, 2), DataOption:=xlSortNormal
    Next
    .SetRange rg: .Header = Hd: .MatchCase = False
    .Orientation = xlTopToBottom: .SortMethod = xlPinYin: .Apply
  End With
End Sub

в стандартный модуль, выполните SplitByDepartment
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Ігор Гончаренко, спасибо, всё работает, но копирует столбцы с G:G по I:I, а можно сделать чтобы столбец F:F тоже копировался, т.е чтоб на новый лист выводились все 4 столбца. Или нужно самому вручную вставить пустой столбец после I:I, в него скопировать данные из F:F, и заменить
Код
Set rg = Intersect([g:i], ActiveSheet.UsedRange)

на

Код
 Set rg = Intersect([g:j], ActiveSheet.UsedRange)

и после этого запускать макрос?

 
лучше выполните этот макрос
Код
Sub SplitByDepartment()
  Dim rg As Range, r&, c&
  Set rg = Intersect(Rows(4).Resize(999999), [f4].CurrentRegion)
  SortRangeBy rg, Array(2), 0
  r = 1
  Do While Not IsEmpty(rg.Cells(r, 1))
    c = WorksheetFunction.CountIf(rg.Columns(2), rg.Cells(r, 2))
    Worksheets.Add after:=Worksheets(Worksheets.Count)
    ActiveSheet.Name = rg.Cells(r, 2)
    rg.Parent.Cells(2, 6).Resize(1, 4).Copy [a1]: rg.Rows(r).Resize(c).Copy [a2]
    r = r + c
  Loop
End Sub
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
При попытке выполнить макрос выдаёт ошибку. Скрины ниже.
 
см. сообщение 5
предполагалось тот SplitByDepartment заменить новым
без SortRangeBy все это в топку (не работает)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
Вас понял, заменил, и всё отлично сработало, большое спасибо за помощь.  
 
Ігор Гончаренко, при работе макроса с реальной задачей, появилась проблема - в столбце G:G есть наименование подразделений которые содержат более 31 знака, и макрос не срабатывает и выдаёт ошибку так как такое название не "влезает" на лист.
Можно ли сделать так чтобы макрос давал стандартные названия новым листам - лист2, лист3, лист4 и т.д.
 
уберите строку
Код
ActiveSheet.Name = rg.Cells(r, 2)
 
If Len(rg.Cells(r, 2))<32 then ActiveSheet.Name = rg.Cells(r, 2)
Программисты - это люди, решающие проблемы, о существовании которых Вы не подозревали, методами, которых Вы не понимаете!
 
RAN, большое спасибо  
 
А можно так
Код
ActiveSheet.Name = Left(rg.Cells(r, 2), 31)
 
Ігор Гончаренко, #13 тоже отлично работает  
Страницы: 1
Наверх