Добрый день. Очень нужна помощь с циклом в макросе. Есть исходный файл с данными об объемах продаж в разрезе руководителей региона. Нужно, чтобы макрос отбирал данные по признаку "руководитель региона", копировал в новую книгу и строил сводную таблицу по этой выборке. Добиться этого по одному руководителю региона у меня получилось, но перебрать всех руководителей циклом никак не выходит. Помогите, пожалуйста, найти ошибку (с 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 |
