Страницы: 1
RSS
Разделение таблицы по разным листам (разделениея по менеджерам)
 
Здравствуйте, нашел здесь на форуме макрос (сам в ВБА я ноль), который таблицу по заданному диапазону делит на листы. Когда задаю делить по столбцу А1:А  работает отлично, сейчас в примере делает не правильно (в примере показано как он делит сейчас), хочу на листе "Итог" разнести по менеджерам столбец Е, помогите пожалуйста какую строчку надо править еще что бы в дальнейшем я мог назначать любой столбец, если у кого есть лучше макрос буду рад ))
 
Удалите все листы, кроме листа Итог
Если делить по менеджеру, то ColFiltr = 5 'столбец для фильтра
Код
Sub SplitTable()
Dim i As Long
Dim iLastRow As Long
Dim Rng As Range
Dim RngVisible As Range
Dim Sht As Worksheet
Dim ColFiltr As Integer
  ColFiltr = 5 'столбец для фильтра
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("Итог")
 iLastRow = Cells(Rows.Count, ColFiltr).End(xlUp).Row
   Set Rng = Sht.Range("A1:G" & iLastRow)
     Columns("K").ClearContents
     Range(Cells(1, ColFiltr), Cells(iLastRow, ColFiltr)).AdvancedFilter xlFilterCopy, _
                                             CopyToRange:=Range("K1"), Unique:=True
     iLastRow = Cells(Rows.Count, "K").End(xlUp).Row
  For i = 2 To iLastRow
    Rng.AutoFilter Field:=ColFiltr, Criteria1:=Cells(i, "K")
       Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        'создаем новый лист
       With Worksheets.Add(After:=Worksheets(Worksheets.Count))
         .Range("A1").PasteSpecial xlPasteColumnWidths
         .Range("A1").PasteSpecial xlPasteFormats
         .Range("A1").PasteSpecial xlPasteValues
         .Name = Sht.Cells(i, "K")
         .Range("A1").Select
       End With
        Sht.Activate
        Sht.AutoFilter.Range.AutoFilter
  Next
    Columns("K").Delete
Application.ScreenUpdating = True
End Sub
 
Евген1788, так попробуйте
Код
            Set aRange = .Range("E1:E" & LastRow)
            aRange.AutoFilter Field:=5, Criteria1:=FilterData

Только про название не забудьте
Добавьте к имеющемуся названию - , фильтруя по менеджеру
 
Михаил Л, Спасибо огромное, я поменял вместо 1 поставил 5 ( я так понял помимо диапазона в данном месте надо менять номер столбца ?)  и получилось как хотел,  только не понял что имели ввиду про название?
 
Цитата
Евген1788 написал:
хочу на листе "Итог" разнести по менеджерам столбец Е
Поясните подробнее, что нужно сделать на листе "Итог"?
Понимаю что на листе итог делать ничего не нужно, тогда поясните подробнее где и что нужно сделать и покажите хоть одну строку конечного результата. Где, что и в каком виде должно получиться. Текст макроса даже и не смотрел, потому что он создал только листы, а что должно быть на этих листах не понятно.
Цитата
Евген1788 написал:
сейчас в примере делает не правильно
А как должно быть, чтобы вы сказали, что это правильно? Покажите в файле. Поработайте руками, вместо макроса.
Цитата
Евген1788 написал:
НЕ ПОЙМУ ЧТО ВЫ ХОТИТЕ!!!!!!
 Модератор хочет чтобы на форуме был порядок и требования правил выполнялись. Если внимательно прочесть правила форума и подготовить файл пример в соответствии с правилами, то не будет лишних вопросов в теме и вы быстрее получите нужный вам ответ. А сейчас несколько постов будет с вопросами " А чего бы вы хотели и в каком виде?" Прочтите внимательно пункт 2.2 и 2.3 правил.
 Вы просите помощи в разбиении таблицы с листа "Итог" на отдельные листы с фамилией менеджера, или вы просите исправить найденный вами, неправильно работающий для решения вашей задачи, макрос?
 Как вы думаете,что быстрее, написать новый макрос или разобраться как работает найденный вами макрос, понять что он не подходит для решения вашей задачи и написать новый макрос?
 Опишите подробнее что и в каком виде вы хотите получить, а вам предложат варианты решения, возможно это будет не макрос, а сводные таблицы или формулы. Попробуйте без макросов, сводной таблицей отобразить страницы фильтра отчета.
Изменено: gling - 04.05.2020 20:00:53
 
gling, Спасибо что заметили меня)) файл прикреплю, тот что Вам пришлю я поделил по категориям,  пользователь Михаил Л, уже прислал ответ чуть выше, я всего навсего одну цифру не правил
 
Евген1788, OFF нужно было так и ответить вам -если вам интересно и нужно получить ответ изучайте VBA, открывайте книги по программированию VBA и тогда сделаете то что нужно Вам.  :D  
Изменено: Mershik - 04.05.2020 19:56:21
Не бойтесь совершенства. Вам его не достичь.
 
Kuzmich, Спасибо супер, теперь на будущее подскажите, если будет другая таблица и диапазон для разбивки мне нужно менять строки №  8   и 12 ?
 
В макросе столбец К используется для отбора уникальных значений. В новой таблице надо будет выбрать
для отбора столбец вне вашей таблицы.
 
кнопка цитирования е для бездумного копирования [МОДЕРАТОР]

Посмотрите пожалуйста, № 8, 12, 13, 15, 18,25,31  это я как понял строки в которых в будущем нужно менять, или еще я что то упустил?
 
Цитата
или еще я что то упустил?
А строку 16
 
Точно, спасибо, скажите как то повлияет на работу макроса если я сейчас вместо столбца "К" задам столбец "XEP" ( до таких размеров таблицы обычно не доходят) ?  это я хочу что бы потом меньше вносить изменений ?
 
Лучше сделайте изменения в макросе. Найдите программно последний столбец таблицы
и выберите столбец для отбора последний столбец + 2
 
Kuzmich, для меня програмно не просто))) у моего способа могут быть проблемы?  
 
Код
Sub SplitTable()
Dim i As Long
Dim iLastRow As Long
Dim Rng As Range
Dim RngVisible As Range
Dim Sht As Worksheet
Dim iLastCol As Integer
Dim ColFiltr As Integer
  ColFiltr = 5 'столбец для фильтра
Application.ScreenUpdating = False
  Set Sht = ThisWorkbook.Worksheets("Итог")
 iLastRow = Cells(Rows.Count, ColFiltr).End(xlUp).Row
 iLastCol = Cells(1, Columns.Count).End(xlToLeft).Column
   Set Rng = Sht.Range(Sht.Cells(1, 1), Sht.Cells(iLastRow, iLastCol))
     Columns(iLastCol + 2).ClearContents
     Range(Cells(1, ColFiltr), Cells(iLastRow, ColFiltr)).AdvancedFilter xlFilterCopy, _
                                             CopyToRange:=Cells(1, iLastCol + 2), Unique:=True
     iLastRow = Cells(Rows.Count, iLastCol + 2).End(xlUp).Row
  For i = 2 To iLastRow
    Rng.AutoFilter Field:=ColFiltr, Criteria1:=Cells(i, iLastCol + 2)
       Sht.AutoFilter.Range.SpecialCells(xlCellTypeVisible).Copy
        'создаем новый лист
       With Worksheets.Add(After:=Worksheets(Worksheets.Count))
         .Range("A1").PasteSpecial xlPasteColumnWidths
         .Range("A1").PasteSpecial xlPasteFormats
         .Range("A1").PasteSpecial xlPasteValues
         .Name = Sht.Cells(i, iLastCol + 2)
         .Range("A1").Select
       End With
        Sht.Activate
        Sht.AutoFilter.Range.AutoFilter
  Next
    Columns(iLastCol + 2).Delete
Application.ScreenUpdating = True
End Sub
 
Kuzmich, нет слов просто, спасибо огромное, теперь надо менять только в строке №9?

Еще вопрос, когда текстовые значения в столбце по которому делю данные все отлично, но попробовал делить по датам и на листах только заголовки, что нужно добавить в макрос ?
 
Цитата
Евген1788 написал:
попробовал делить по датам и на листах только заголовки
Нагуглил возможность фильтровать по дате
Код
'Option Explicit
Sub kopyMyData()
Dim Sh As Object
Dim shIshodn As Worksheet, shMyTMP As Worksheet
Dim rng As Range, FilterData, k, aRange As Range
Dim maxrow As Long, minrow As Long, uniq As Long
Dim r As Long, jBaza As Long, kIsh As Long
 'отключаем тормоза
    With Application
        .ScreenUpdating = False 'обновление экрана
        .DisplayAlerts = False 'системные предупреждения
        .Calculation = xlManual 'автоматический пересчет формул
On Error Resume Next
'назначаем имена листов переменным
Set shIshodn = ActiveWorkbook.Worksheets("Итог")
shIshodn.AutoFilterMode = False
    If WorksheetIsExist("MyTMP") Then
        MsgBox "Лист MyTMP используется макросом, удалите или переименуйте существующий!", vbExclamation, "Ошибка"
        Exit Sub
    End If
   Worksheets.Add.Name = "MyTMP"
Set shMyTMP = ThisWorkbook.Sheets("MyTMP")
shIshodn.Range("D1:D" & shIshodn.Cells(Rows.Count, 1).End(xlUp).Row).Copy Destination:=shMyTMP.Range("A1")
shMyTMP.Activate
'===================extrakt uniq, by Slan http://www.planetaexcel.ru/forum.php
With shMyTMP
    maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
    If .Cells(1, 1).Formula = "" Then
    minrow = .Cells(1, 1).End(xlDown).Row
    Else
    minrow = 1
    End If
    .Range(Cells(minrow, 1), Cells(maxrow, 1)).AdvancedFilter Action:=xlFilterInPlace, Unique:=True
    uniq = Range(Cells(minrow, 1), Cells(maxrow, 1)).SpecialCells(xlCellTypeVisible).Cells.Count
    If uniq < maxrow - minrow + 1 Then
    .Range(Cells(minrow, 1), Cells(maxrow, 1)).SpecialCells(xlCellTypeVisible).EntireRow.Copy Destination:=.Cells(maxrow + 1, 1)
    .ShowAllData
    .Range(Cells(minrow, 1), Cells(maxrow, 1)).EntireRow.Delete
    maxrow = .Cells(Rows.Count, 1).End(xlUp).Row
    End If
End With
'=================================
'определяем и устанавливаем автофильтром диапазон ячеек с исходными данными для переноса
For jBaza = 2 To maxrow
      k = shMyTMP.Range("A" & jBaza).Value
    FilterData = k
      If IsEmpty(FilterData) Then Exit Sub
    ' Фильтровать
       
        With shIshodn.UsedRange
                    LastRow = .Cells.SpecialCells(xlCellTypeLastCell).Row
            
            Set aRange = .Range("D1:D" & LastRow)
            Range("Таблица1[Дата]").NumberFormat = "General"
            
            aRange.AutoFilter Field:=4, Criteria1:=CDbl(CDate(FilterData))
           ' Columns("N:N").NumberFormat = "m\/yyyy;@"    CDbl(CDate(
            '                If ActiveCell.Rows.Hidden Then
'                    ' Если активная ячейка попала на скрытый ряд - стать ниже последней строки фильтра
'                    Cells(rng.Cells(1, 1).Offset(rng.Rows.Count, 0).Row, ActiveCell.Column).Select
'                End If
 '--------------------------------------------------------------
                    'Создание нового листа и вставка данных и форматов
                    Worksheets.Add.Name = k
 '---------------------------------------------------------------
        'вычисляем последнюю незаполненную строку на листе shIshodn и копируем данные
                r = .Cells(Rows.Count, 1).End(xlUp).Row
                .Range("A1:G" & r).SpecialCells(xlCellTypeVisible).Copy
                                        'вставляем данные в созданный лист
                        With ActiveSheet.Range("A1")
                            .PasteSpecial Paste:=xlValues
                            .PasteSpecial Paste:=xlPasteFormats
                             Columns("D:D").NumberFormat = "dd/mm/yyyy"
                            .Range("A1").Select
                        End With
                        End With
        shIshodn.AutoFilterMode = False
Next jBaza
        'удаляем служебный лист
        shMyTMP.Delete
        ActiveWorkbook.Save
        
'включаем все, что отключали
        .Calculation = xlAutomatic  '
        .DisplayAlerts = True  '
        .ScreenUpdating = True '
        End With
        Range("Таблица1[Дата]").AutoFilter Field:=4
        Range("Таблица1[Дата]").NumberFormat = "dd/mm/yyyy"
        
End Sub
'==================
Private Function WorksheetIsExist(iName$) As Boolean
'***********************************************'
'   Дата создания 01/01/2005
'   Автор Климов Павел Юрьевич
'   http://www.msoffice.nm.ru
'***********************************************'
'вспомогательная функция проверяет наличие листа
    Dim iList As Worksheet
    For Each iList In Worksheets
        If StrComp(iList.Name, iName$, vbTextCompare) = 0 Then
           WorksheetIsExist = True
           Exit Function
        End If
    Next
    WorksheetIsExist = False
End Function


[spoiler][/spoiler]
Изменено: Михаил Л - 05.05.2020 11:54:26
 
Михаил Л, спасибо огромное. Буду пробовать.  
Страницы: 1
Наверх