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