'выставляем поля фильтрации сводной

Sub Перестроить_фильтр_из_активного_листа()

strShName = ActiveSheet.Name '"Pv_DPU_FIN"

gg = FnFiltersPt(strShName)

End Sub

Function FnFiltersPt(ByVal strShName As String) As Boolean

Dim Pt As PivotTable

Dim Pf As PivotField, strFldName As String

Dim oPi As PivotItem

Dim FnDicPi As Object

Dim iNbItems As Long 'количество элементов в поле

Dim iNbItem As Long '№ обрабатываемого элемента

Dim strItem As String

Dim strItemValue As Boolean

With ThisWorkbook.Sheets(strShName)

If .PivotTables.Count > 0 Then

'массив фильтров

'словарь элементов для фильтра

iNbCln = 2 'ThisWorkbook.Sheets("ListFilters").Cells(1, 256).End(xlToLeft).Column

iNbRow = .Columns(1).Rows(65536).End(xlUp).Row

If iNbRow < 2 Then FnFiltersPt = False: Exit Function

aPi = Range(.Cells(2, 1), .Cells(iNbRow, 2)).Value 'массив для словаря

'Словарь

Set FnDicPf = FnDicInAr(aPi)

' Set FnDicPi = CreateObject("scripting.dictionary"): FnDicPi.comparemode = 1

' For j = LBound(aPi) To UBound(aPi)

' strPi = Trim(aPi(j, 1))

' If Not FnDicPi.exists(strPi) Then FnDicPi.Add strPi, Trim(aPi(j, 2))

' Next 'j

On Error Resume Next

For Each oPt In .PivotTables 'цикл по всем сводным таблицам

Set Pt = oPt

With Pt

.ManualUpdate = True

For Each oFld In .PivotFields 'цикл по полям таблицы

' Stop

If oFld.Orientation = xlPageField Then oFld.Orientation = xlHidden 'выкинуть из фильтров

strFldName = oFld.Name '.Caption

If FnDicPf.exists(strFldName) Then 'если поле есть в словаре

oFld.Orientation = xlPageField 'ориентация(перекинуть в фильтры)

Set Pf = .PivotFields(strFldName)

If Len(FnDicPf.Item(strFldName)) > 0 Then 'если элементы поля заданы(если не заданы, то просто кидаем в фильтр)

m = Split(FnDicPf.Item(strFldName), ", ", -1, vbTextCompare)

Set FnDicPi = FnDicInAr(m)

If Not Pf Is Nothing Then 'если поле есть в таблице

iNbItems = Pf.PivotItems.Count

iNbItem = 1

For Each oPi In Pf.PivotItems 'цикл по элементам поля

oPi.Visible = True 'сначала включаем элемент

If FnDicPi.exists(oPi.Name) Then 'если элемент есть в словаре

oPi.Visible = True

Else

oPi.Visible = False

End If

'строка состояния

If oPi.Name <> "(blank)" Then

strItem = oPi.Name

strItemValue = oPi.Visible

Application.StatusBar = Pf & " => " & iNbItem & " / " & iNbItems & " - " & strItem & "=" & strItemValue

iNbItem = iNbItem + 1

End If

Next 'oPf

End If

End If

End If

Next 'oFld

.ManualUpdate = False

End With

Next 'oPt

Else

' FnFiltersPt = False: Exit Function

End If

End With

Application.StatusBar = False

End Function

'словарь из двумерного(Одномерного) массива

Function FnDicInAr(ByVal aTemp As Variant) As Object

Dim FnDicPi As Object

Dim strPi As String

Dim i As Long

Dim iNbCln1 As Integer 'первый столбец

Dim iNbCln2 As Integer 'второй столбец

On Error Resume Next

iNbCln1 = LBound(aTemp)

'iNbCln2 = UBound(aTemp, 2)

iNbCln2 = RazmerArray(aTemp)

'If iNbCln1 <> iNbCln2 Then Stop

Set FnDicPi = CreateObject("scripting.dictionary"): FnDicPi.comparemode = 1

For i = LBound(aTemp) To UBound(aTemp)

If iNbCln1 = iNbCln2 Then 'если два столбца

strKey = Trim(aTemp(i))

If Not FnDicPi.exists(strKey) Then FnDicPi.Add strKey, strKey

Else

strKey = aTemp(i, iNbCln1) 'Trim(aTemp(i, iNbCln1))

strItem = aTemp(i, iNbCln2) 'Trim(aTemp(i, iNbCln2))

If Not FnDicPi.exists(strKey) Then FnDicPi.Add strKey, strItem

End If

Next 'j

Set FnDicInAr = FnDicPi

End Function

''http://www.planetaexcel.ru/forum/?PAGE_NAME=read&FID=8&TID=25891

''вообще-то верхняя граница может быть любой...( в том числе и отрицательной)

''я б сделал так:

Function RazmerArray(A) As Long

Dim k As Long

On Error GoTo KOH

j = LBound(A)

k = j '1

While UBound(A, k) >= LBound(A, k)

k = k + 1

Wend

KOH:

If k = 0 Then

RazmerArray = 0

Else

RazmerArray = k - 1

End If

End Function