VBA для подключения slicers (ищет улучшения кода)

Question

Наконец-то я нашел код, который будет подключать слайсеры с различными кешами при обновлении сводной таблицы. В основном, когда значение slicer1 изменяется, оно изменит slicer2 на соответствие slicer1, таким образом обновив любую сводную таблицу, связанную со вторым slicer.

Я добавил .Application.ScreenUpdating и .Application.EnableEvents в попытке ускорить макрос, но он все еще отстает и заставляет Excel перестать отвечать на запросы.

Есть ли более прямой способ кодирования этого или есть потенциально нестабильные линии здесь, в результате чего Excel поджарит его мозг?

Private Sub Worksheet_PivotTableUpdate _ 
    (ByVal Target As PivotTable) 
Dim wb As Workbook 
Dim scShort As SlicerCache 
Dim scLong As SlicerCache 
Dim siShort As SlicerItem 
Dim siLong As SlicerItem 

Application.ScreenUpdating = False 
Application.EnableEvents = False 
On Error GoTo errHandler 
Application.ScreenUpdating = False 
Application.EnableEvents = False 

Set wb = ThisWorkbook 
Set scShort = wb.SlicerCaches("Slicer_Department") 
Set scLong = wb.SlicerCaches("Slicer_Department2") 

scLong.ClearManualFilter 

For Each siLong In scLong.VisibleSlicerItems 
    Set siLong = scLong.SlicerItems(siLong.Name) 
    Set siShort = Nothing 
    On Error Resume Next 
    Set siShort = scShort.SlicerItems(siLong.Name) 
    On Error GoTo errHandler 
    If Not siShort Is Nothing Then 
     If siShort.Selected = True Then 
      siLong.Selected = True 
     ElseIf siShort.Selected = False Then 
      siLong.Selected = False 
     End If 
    Else 
     siLong.Selected = False 
    End If 
Next siLong 

exitHandler: 
    Application.ScreenUpdating = True 
    Application.EnableEvents = True 
    Exit Sub 

errHandler: 
    MsgBox "Could not update pivot table" 
    Resume exitHandler 
Application.ScreenUpdating = True 
Application.EnableEvents = True 
End Sub 

исходный код найден на Contextures

Спасибо за любые советы, как всегда.

link to original inquiry:

Answer 1

Если вы хотите только пользователь выбрать только один пункт в то время, вы можете сделать это очень быстро, используя следующий трюк, которая использует от причуды делать с PageFields. Вот пример, где я синхронизую три разных сводных таблицы, которые находятся в разных кэшах.

1. Настройка ведомого сводную таблицу для каждого из мастер-PivotTables где-то вне поля зрения, и поставить в поле интересов в каждом из них как PageField, как это:

   

2. Убедитесь, что «Выбор нескольких элементов» флажок снят для каждого из этих ведомых PivotTables:
3. Добавить Slicer для каждого из этих Slaves. Опять же, это будет где-то вне поля зрения:
4. Подключите каждый из этих Slicers до фактических сводных таблиц, с которыми вы должны были начать. (Т.е. соединить каждую скрытую Slicer к его видимому коллеге сводной таблицы, используя поле Report Connections

Теперь это где умный хак приходит в:. Двигается ломтерезка, который подключен к PivotTable1 работорговли PivotTable в основной лист, чтобы пользователь мог щелкнуть по нему. Когда они выбирают элемент, используя его, он генерирует событие PivotTable_Update для этого PivotTable1 Slave PivotTable, за которым мы следим. И затем мы устанавливаем .PageField из этих других ведомые сводные таблицы для соответствия .PageField Сводная таблица SlaveTable1 Сводная таблица. И затем происходит больше волшебства: этот сингл s выборы в этих подчиненных PageFields реплицируются в основных сводных таблицах благодаря тем скрытым Slicers, которые мы установили ранее. Нет необходимости в VBA. Не требуется медленной итерации. Просто молниеносная синхронизация.

Вот как вся установка выглядит:

...и это будет работать, даже если поле вы хотите фильтровать не видно ни в одном из ваших шарниров:

Вот код, который достигает этой цели:

Option Explicit 

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable) 

Dim pt As PivotTable 
Dim pf As PivotField 
Dim sCurrentPage As String 
Dim vItem As Variant 
Dim vArray As Variant 

'######################## 
'# Change these to suit # 
'######################## 

Const sField As String = "Name" 
vArray = Array("PivotTable2 Slave", "PivotTable3 Slave") 


If Target.Name = "PivotTable1 Slave" Then 
    On Error GoTo errhandler 
    With Application 
     .ScreenUpdating = False 
     .Calculation = xlCalculationManual 
     .EnableEvents = False 
    End With 

    'Find out what item they just selected 
    Set pf = Target.PivotFields(sField) 
    With pf 
     If .EnableMultiplePageItems Then 
      .ClearAllFilters 
      .EnableMultiplePageItems = False 
      sCurrentPage = "(All)" 
     Else: 
      sCurrentPage = .CurrentPage 
     End If 
    End With 

    'Change the other slave pivots to match. Slicers will pass on those settings 
    For Each vItem In vArray 
     Set pt = ActiveSheet.PivotTables(vItem) 
     Set pf = pt.PivotFields(sField) 
     With pf 
      If .CurrentPage <> sCurrentPage Then 
       .ClearAllFilters 
       .CurrentPage = sCurrentPage 
      End If 
     End With 
    Next vItem 

errhandler: 
    With Application 
     .ScreenUpdating = True 
     .Calculation = xlCalculationAutomatic 
     .EnableEvents = True 
    End With 
End If 

End Sub 

Там немного кода там чтобы пользователь не мог выбрать более одного элемента в слайсере за раз.

Но что, если вы хотите, чтобы Пользователь имел возможность выбрать несколько элементов?

Если вы хотите, чтобы пользователь мог выбирать несколько предметов, все становится еще более сложным. Для начала вам нужно установить для каждого свойства ManualUpdate каждого из них значение TRUE, чтобы они не обновляли каждый элемент PivotItems. И даже тогда, может потребоваться несколько минут, чтобы синхронизировать только одну сводную таблицу, если в ней указано 20 000 элементов. У меня хорошая статья об этом по следующей ссылке, которую я бы рекомендовал вам прочитать, которая показывает, сколько времени требуется, чтобы выполнить различные действия, когда дело доходит до итерации через большое количество PivotItems: http://dailydoseofexcel.com/archives/2013/11/14/filtering-pivots-based-on-external-ranges/

Даже тогда у вас есть много других проблем, которые нужно преодолеть в зависимости от того, что вы делаете. Слайсеры, похоже, действительно замедляют работу, для начала. Читайте мой пост в http://dailydoseofexcel.com/archives/2015/11/17/filtering-pivottables-with-vba-deselect-slicers-first/ для получения дополнительной информации об этом.

Я нахожусь на заключительной стадии запуска коммерческого дополнения, которое делает много этого материала молниеносно, но запуск - это, по крайней мере, месяц.

Answer 2

Я не уверен, что я делаю неправильно. Я разместил свой код ниже, я не нахожу ошибок, просто не обновляю ни один из других slicers/fields. После первого теста срезатель отдела обновил все таблицы один раз, но затем не очистил фильтр или не разрешил другой выбор, поскольку в слайсере «Месяц» я не получил его вообще. Возможно, мне нужно дублировать каждый элемент, чтобы его можно было идентифицировать отдельно? Как и в Dim sCurrentPage As String и Dim sCurrentPage2 As String. Огромное вам спасибо за вашу дальнейшую помощь в этом, я никогда не хотел, чтобы в выходные дни так плохо во время работы над электронной таблицей.

Option Explicit 

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable) 

Dim pt As PivotTable 
Dim pf As PivotField 
Dim sCurrentPage As String 
Dim vItem As Variant 
Dim vArray As Variant 
Dim sField As String 

'######################## 
'# Change these to suit # 
'######################## 

sField = "Department" 
vArray = Array("PivotTable2 Slave", "PivotTable3 Slave") 


If Target.Name = "PivotTable1 Slave" Then 
    On Error GoTo errhandler 
    With Application 
     .ScreenUpdating = False 
     .Calculation = xlCalculationManual 
     .EnableEvents = False 
    End With 

    'Find out what item they just selected 
    Set pf = Target.PivotFields(sField) 
    With pf 
     If .EnableMultiplePageItems Then 
      .ClearAllFilters 
      .EnableMultiplePageItems = False 
      sCurrentPage = "(All)" 
     Else: 
      sCurrentPage = .CurrentPage 
     End If 
    End With 

    'Change the other slave pivots to match. Slicers will pass on those settings 
    For Each vItem In vArray 
     Set pt = ActiveSheet.PivotTables(vItem) 
     Set pf = pt.PivotFields(sField) 
     With pf 
      If .CurrentPage <> sCurrentPage Then 
       .ClearAllFilters 
       .CurrentPage = sCurrentPage 
      End If 
     End With 
    Next vItem 

'######################## 

sField = "Month" 
vArray = Array("PivotTable2 Slave2", "PivotTable3 Slave2") 


If Target.Name = "PivotTable1 Slave2" Then 
    On Error GoTo errhandler 
    With Application 
     .ScreenUpdating = False 
     .Calculation = xlCalculationManual 
     .EnableEvents = False 
    End With 

    'Find out what item they just selected 
    Set pf = Target.PivotFields(sField) 
    With pf 
     If .EnableMultiplePageItems Then 
      .ClearAllFilters 
      .EnableMultiplePageItems = False 
      sCurrentPage = "(All)" 
     Else: 
      sCurrentPage = .CurrentPage 
     End If 
    End With 

    'Change the other slave pivots to match. Slicers will pass on those settings 
    For Each vItem In vArray 
     Set pt = ActiveSheet.PivotTables(vItem) 
     Set pf = pt.PivotFields(sField) 
     With pf 
      If .CurrentPage <> sCurrentPage Then 
       .ClearAllFilters 
       .CurrentPage = sCurrentPage 
      End If 
     End With 
    Next vItem 

errhandler: 
    With Application 
     .ScreenUpdating = True 
     .Calculation = xlCalculationAutomatic 
     .EnableEvents = True 
    End With 
End If 

End Sub