Поиск  Пользователи  Правила 
Закрыть
Логин:
Пароль:
Забыли свой пароль?
Регистрация
Войти
 
Страницы: 1
RSS
Отбор данных и построение сводной таблицы макросом, не работает цикл
 
Добрый день. Очень нужна помощь с циклом в макросе. Есть исходный файл с данными об объемах продаж в разрезе руководителей региона. Нужно, чтобы макрос отбирал данные по признаку "руководитель региона", копировал в новую книгу и строил сводную таблицу по этой выборке. Добиться этого по одному руководителю региона у меня получилось, но перебрать всех руководителей циклом никак не выходит. Помогите, пожалуйста, найти ошибку (с vba раньше не сталкивалась, а макрос очень нужен...)

Код
Sub Main()
 
    Dim WSD As Worksheet
    Dim DRange As Range
    Dim CNumber As Integer
    Dim CRange As Range
    Dim ManCollection As New Collection
    
    Set WSD = ActiveSheet
    
    FinalRow = WSD.Cells(Application.Rows.Count, 1).End(xlUp).Row
    FinalCol = WSD.Cells(1, Application.Columns.Count).End(xlToLeft).Column
    
    Set DRange = WSD.Cells(1, 1).Resize(FinalRow, FinalCol)
    CNumber = FindManagerColumn()
    Set CRange = Columns(CNumber)

    On Error Resume Next
        For Each cell In CRange.Cells
        ManCollection.Add cell.Value, cell.Value
        
    Next
    On Error GoTo 0
    ReDim UniqArray(1 To ManCollection.Count)
    For i = 1 To ManCollection.Count
    UniqArray(i) = ManCollection(i)
    Next
    Range("P1").Resize(ManCollection.Count, 1).Value = WorksheetFunction.Transpose(UniqArray)
    
    Dim oParam, oData, oHeader As Range
        
    Set oParam = ActiveSheet.Range(ActiveSheet.Cells(1, 1), ActiveSheet.Cells(1, 1))
    Set oData = oParam.CurrentRegion

    Set oHeader = oData.Resize(oParam.Rows.Count, oData.Columns.Count)
    Set oData = oData.Offset(oHeader.Rows.Count, 0).Resize(oData.Rows.Count - oHeader.Rows.Count, oData.Columns.Count)
    
    Dim manager As String
    Dim cName As String
    Dim j As Integer
    Dim c As Integer
    
            
    On Error Resume Next
        'For c = 1 To ManCollection.Count 
        'manager = ManCollection.Item(c)
                        
        CRange.Find(What:="Руководитель1", After:=CRange.Cells(1, 1), SearchOrder:=xlByRows).Activate ' здесь вместо "Руководитель1" пробую подставлять manager, чтобы перебрать всех руководителей
        
            If Not Application.Intersect(ActiveCell, oData) Is Nothing Then
                cName = Application.Intersect(ActiveCell.EntireRow, oData).Cells(1, CNumber).Value
    
                Set WBN = Workbooks.Add(xlWBATWorksheet)
                Set WSR = WBN.Worksheets(1)
                WSR.Cells.Clear
                oHeader.Copy
                oHeader.PasteSpecial (xlPasteColumnWidths)
                WSR.Cells(1, 1).PasteSpecial (xlPasteColumnWidths)
                oHeader.Copy WSR.Cells(1, 1)
                j = oHeader.Rows.Count + 1
                Application.CutCopyMode = False

                For Each r In oData.Rows
                    If r.Cells(1, CNumber) = cName Then
                        r.Copy WSR.Cells(j, 1)
                        j = j + 1
                    End If
                Next
            End If
            
            'Set WSR = Nothing
            Set oData = Nothing
            Set oHeader = Nothing
            Set oParam = Nothing
            
            Dim PTCache As PivotCache
            Dim PT As PivotTable
            
            FinalRow = WSR.Cells(Application.Rows.Count, 1).End(xlUp).Row
            FinalCol = WSR.Cells(1, Application.Columns.Count).End(xlToLeft).Column
            Set PRange = WSR.Cells(1, 1).Resize(FinalRow, FinalCol)
            Set PTCache = ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, SourceData:=PRange.Address)
        
            ' Create the Pivot Table from the Pivot Cache
            Set PT = PTCache.CreatePivotTable(TableDestination:=WSR.Cells(2, FinalCol + 2), TableName:="PivotTable1")
        
            ' Turn off updating while building the table
            PT.ManualUpdate = True
        
            ' Set up the row fields
            PT.AddFields RowFields:=Array("Сотрудник", "Счет")
        
            ' Set up the data fields
            With PT.PivotFields("Кол-во ")
                .Orientation = xlDataField
                .Function = xlSum
                .Position = 1
                .NumberFormat = "# ##0"
                .Name = "Объем"
            End With
        
            ' Sort stores descending by sum of revenue
            PT.PivotFields("Счет").AutoSort Order:=xlDescending, _
                Field:="Объем"
                
             ' 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
     
    'Next
 
End Sub
Function FindManagerColumn()
    
    sWhatFind = "Руководитель региона"
    Dim HRange As Range
    Set HRange = Range("A1: T3")
    HRange.Find(What:=sWhatFind, After:=HRange.Cells(1, 1), LookAt:=xlWhole, SearchOrder:=xlByRows).Activate
    nColumn = ActiveCell.Column
    FindManagerColumn = nColumn 
  
End Function
 
Цитата
но перебрать всех руководителей циклом никак не выходит
Я не понял всех этих танцев с коллекциями, на мой взгляд это лишнее
Стройте сводную прямо на этом листе
Код
            Dim PTCache As PivotCache
            Dim PT As PivotTable
            
            FinalRow = Cells(Application.Rows.Count, 1).End(xlUp).Row
            FinalCol = Cells(1, Application.Columns.Count).End(xlToLeft).Column
            Set PRange = Cells(1, 1).Resize(FinalRow, FinalCol)
            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, FinalCol + 2), TableName:="PivotTable1")
        
            ' Turn off updating while building the table
            PT.ManualUpdate = True
        
            ' Set up the row fields
            PT.AddFields RowFields:=Array("Руководитель региона", "Сотрудник", "Счет")
        
            ' Set up the data fields
            With PT.PivotFields("Кол-во ")
                .Orientation = xlDataField
                .Function = xlSum
                .Position = 1
                .NumberFormat = "# ##0"
                .Name = "Объем"
            End With
        
            ' Sort stores descending by sum of revenue
            PT.PivotFields("Счет").AutoSort Order:=xlDescending, _
                Field:="Объем"
                
             ' 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
    End Sub
 
Не получается заставить работать Ваш вариант. Кроме начала процедуры в него больше ничего не требуется добавлять?
 
Цитата
ничего не требуется добавлять
Если вы используете OptionExplicit, то надо определить FinalRow и FinalCol
и главное вставить в код руководителя региона
Код
 PT.AddFields RowFields:=Array("Руководитель региона", "Сотрудник", "Счет")
 
Я очень извиняюсь... Внесла изменения, но все равно выдает ошибку. Вы могли бы вариант, который у Вас срабатывает, прикрепить файлом? Возможно, я что-то еще делаю не так...
 
Цитата
но все равно выдает ошибку.
На листе не должно быть сводной таблицы
 
Теперь поняла, что Вы имели в виду. Дело в том, что результат будет отправляться руководителям регионов, а они не должны видеть итоги работы друг друга. Делать выборку по каждому руководителю фильтром не стала, потому что руководителей около 20 и их перечень может изменяться (поэтому поименно прописывать каждого в коде для выполнения фильтрации не вариант). Поэтому чтобы разрезать массив на отдельных руководителей я делала коллекцию руководителей и хотела в цикле по ней пройти, чтобы для каждого создать отдельную книгу, куда скопировать касающиеся его данные и создать сводную таблицу по ним. Но не смогла найти ошибку, из-за которой цикл, перебирающий руководителей, не отрабатывает.  
 
Цитата
чтобы разрезать массив на отдельных руководителей
Используйте в сводной таблице для Руководителя региона поле страниц и циклом
создавайте новую книгу с именем листа =номеру руководителя. Не забудьте только
сохранить вновь созданные книги под нужным вам именем.
Код
Sub Main()
Dim PTCache As PivotCache
Dim PT As PivotTable
Dim FinalRow As Long
Dim FinalCol As Integer
Dim WBN As Workbook
Dim WSh As Worksheet
    FinalRow = Cells(Application.Rows.Count, 1).End(xlUp).Row
    FinalCol = Cells(1, Application.Columns.Count).End(xlToLeft).Column
       Set PRange = Cells(1, 1).Resize(FinalRow, FinalCol)
       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, FinalCol + 2), TableName:="PivotTable1")
            ' Turn off updating while building the table
            PT.ManualUpdate = True
            ' Set up the row fields
            PT.AddFields RowFields:=Array("Сотрудник", "Счет"), PageFields:="Руководитель региона"
            ' Set up the data fields
            With PT.PivotFields("Кол-во ")
                .Orientation = xlDataField
                .Function = xlSum
                .Position = 1
                .NumberFormat = "# ##0"
                .Name = "Объем"
            End With
            ' Sort stores descending by sum of revenue
            PT.PivotFields("Счет").AutoSort Order:=xlDescending, _
                Field:="Объем"
             ' 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
  iStr = 0
    'цикл по значениям поля Руководитель региона
  For Each PivItem In PT.PivotFields("Руководитель региона").PivotItems
    iStr = iStr + 1
    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
  Next
End Sub
Страницы: 1
Читают тему (гостей: 1)
Наверх