Страницы: 1
RSS
Создание листов по фильтру со сводной таблицы и их переименование, Макрос
 
Добрый день.

Помогите новичку, плиз.
Задача - сделать макросом для каждого менеджера (брика) свой отдельный лист с одной сводной таблицы. И переименовать каждый лист именем брика (ячейка B1)

Проблема - в том, что для троих менеджеров в тестовом режиме я макросы создал (см. вложенный файл), но в реальности их больше пятидесяти и каждый месяц
некоторые их них будут менять название. Ручками, конечно, каждый раз править можно, но - не спортивно.
(поиском некоторые примеры похожего решения находил, но что-то никак не подправлю под свои реалии).

Спасибо, за помощь.
Изменено: tigor - 25.09.2019 10:40:52 (обновил файл)
 
Задачу с переименованием решил подстановкой вот этой строки:
Код
ActiveSheet.Name = [B1].Value

Осталось только наладить создание листов со сводной на каждый брик (в реальности их будет >50).  
Изменено: tigor - 25.09.2019 10:41:33
 
Вариант: сделать отдельно список всех менеджеров и пробежаться по нему циклом.
 
Здравствуйте. А что обязательно нужно макросом, встроенные возможности Excel не устраивают?
Активируйте любую ячейку сводной таблицы-- далее по вкладкам: Работа со сводными таблицами -- Параметры --- на треугольничек рядом с кнопкой Параметры -- Отобразить страницы фильтра отчета -- Ок.
Макрорекордером получился такой макрос:
Код
Sub Макрос1()
    ActiveSheet.PivotTables("Сводная таблица2").ShowPages PageField:="Брик"
End Sub
Изменено: gling - 24.09.2019 20:09:36
 
gling, здравствуйте! Прикольно, не знал про такое :)
 
Цитата
_Igor_61 написал: Вариант: сделать отдельно список всех менеджеров и пробежаться по нему циклом.
Спасибо. Как раз думал над таким вариантом.
БОЖЕСТВЕННО! Большое спасибо.

Попробуем.
Цитата
А что обязательно нужно макросом, встроенные возможности Excel не устраивают?
Да, работает. Спасибо. Но прелесть макроса в том, что можно в него вставить доп.операции. Например, скопировать и вставить как значение (каждая закладка будет отдельным файлом и оправляться по почте каждому).
Изменено: tigor - 25.09.2019 10:42:10
 
Цитата
Но прелесть макроса в том....
Запускать при активном листе Первичка, отдельные файлы по каждому менеджеру создаются в той же папке, где и исходный файл
Код
Sub Main()
Dim PRange As Range
Dim PTCache As PivotCache
Dim PT As PivotTable
Dim iLastRow As Long
Dim iLastCol As Integer
Dim WBN As Workbook
Dim WSh As Worksheet
    iLastRow = Cells(Application.Rows.Count, 1).End(xlUp).Row - 1
    iLastCol = Cells(1, Application.Columns.Count).End(xlToLeft).Column
       Set PRange = Cells(1, 1).Resize(iLastRow, iLastCol)
       Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=PRange.Address)
         ' Create the Pivot Table from the Pivot Cache
         Set PT = PTCache.CreatePivotTable(TableDestination:=Cells(2, iLastCol + 2), TableName:="PivotTable1")
            ' Turn off updating while building the table
            PT.ManualUpdate = True
            ' область строк и страницы
            PT.AddFields RowFields:="Продукт", ColumnFields:="Данные", PageFields:="Брик"
            ' определяем область данных
            With PT.PivotFields("для БТ")
                .Orientation = xlDataField
                .Function = xlSum
                .Position = 1
                .NumberFormat = "# ##0.00"
                .Name = "сумма по полю для БТ"
            End With
            With PT.PivotFields("% от макс бон, руб.")
                .Orientation = xlDataField
                .Function = xlSum
                .Position = 1
                .NumberFormat = "# ##0.00"
                .Name = "сумма по полю % от макс бон, руб."
            End With
            With PT.PivotFields("Факт уп")
                .Orientation = xlDataField
                .Function = xlSum
                .Position = 1
                .NumberFormat = "# ##0.00"
                .Name = "сумма по полю Факт.уп"
            End With
             ' Ensure that you get zeroes instead of blanks in the data area
            PT.NullString = "0"
            ' Calc the pivot table
            PT.ManualUpdate = False
            PT.ManualUpdate = True
Dim iStr As Integer
Dim PivItem As Object
    'цикл по значениям поля Брик
  For Each PivItem In PT.PivotFields("Брик").PivotItems
    PT.PivotFields("Брик").CurrentPage = PivItem.Name
      'пересчитать сводную таблицу
      PT.ManualUpdate = False
      PT.ManualUpdate = True
      Set WBN = Workbooks.Add(xlWBATWorksheet)
      Set WSh = WBN.Worksheets(1)
          WSh.Name = PivItem.Name
          'копируем диапазон соответствующего менеджера
          PT.TableRange2.Offset(3, 0).Copy
          WSh.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
          WBN.SaveAs Filename:=ThisWorkbook.Path & "\" & WSh.Name & ".xls"
          WBN.Close SaveChanges:=True
  Next
End Sub
 
Kuzmich,  Большое вам спасибо!!! Бомба! Все как надо.

Осталось только в конечные таблицы форматирование добавить (внешний вид).  
Изменено: tigor - 25.09.2019 12:56:31
 
Цитата
Осталось только в конечные таблицы форматирование добавить
Добавьте в макрос
Код
          WSh.Range("A2:E2").PasteSpecial xlPasteColumnWidths
          WSh.Range("A2").PasteSpecial xlPasteValuesAndNumberFormats
            iLastRow = WSh.Cells(WSh.Rows.Count, 1).End(xlUp).Row
            WSh.Range("A2:D" & iLastRow).Borders.Weight = xlThin
            WSh.Range("A2:D2").Font.Bold = True
            WSh.Range("A" & iLastRow & ":D" & iLastRow).Font.Bold = True
            WSh.Range("A1").Select
          WBN.SaveAs Filename:=ThisWorkbook.Path & "\" & WSh.Name & ".xls"
          WBN.Close SaveChanges:=True
 
Kuzmich,

Спасибо большое! Все работает отлично.
Страницы: 1
Наверх