'--------------------------------------------------------------------------------------

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

'задать имена для сводных и для временных шкал

Dim strSL_Main As String, strSL_ChLd As String

Select Case Target

Case "pt_Main" 'имя сводной

strSL_Main = "SL_Date_Main"

strSL_ChLd = "SL_Date_ChLd"

Case "pt_ChLd" 'имя сводной

strSL_Main = "SL_Date_ChLd"

strSL_ChLd = "SL_Date_Main"

Case Else

Call EventsChange(True)

Exit Sub

End Select

Call EventsChange(False)

'синхронизация по временной шкале

': StartDate : #01.09.2020# : Variant/Date

': EndDate : #30.09.2020# : Variant/Date

Set oSL_Main = ThisWorkbook.SlicerCaches(strSL_Main)

Set oSL = ThisWorkbook.SlicerCaches(strSL_ChLd)

Dim Lng_FilterType As Long

On Error GoTo Err_Slicer_FilterType

Lng_FilterType = oSL_Main.TimelineState.FilterType '(35)= xlDateBetween

Err_Slicer_FilterType:

Select Case Lng_FilterType

Case 29

Call oSL.TimelineState.SetFilterDateRange(oSL_Main.TimelineState.StartDate, oSL_Main.TimelineState.EndDate)

Case 35

Call oSL.TimelineState.SetFilterDateRange(oSL_Main.TimelineState.StartDate, oSL_Main.TimelineState.EndDate)

Case Else

ThisWorkbook.SlicerCaches(strSL_ChLd).ClearDateFilter

End Select

If Lng_FilterType = 35 Then

Call oSL.TimelineState.SetFilterDateRange(oSL_Main.TimelineState.StartDate, oSL_Main.TimelineState.EndDate)

Else

ThisWorkbook.SlicerCaches(strSL_ChLd).ClearDateFilter

End If

Call EventsChange(True)

End Sub

'--------------------------------------------------------------------------------------

''тоже перехватывает... но PivotTableUpdate раньше.

'Private Sub Worksheet_PivotTableChangeSync(ByVal Target As PivotTable)

'End Sub

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

Dim strSL_Main As String, strSL_ChLd As String

Select Case Target

Case "pt_Main" 'имя сводной

strSL_Main = "SL_Date_Main"

strSL_ChLd = "SL_Date_ChLd"

Case "pt_ChLd" 'имя сводной

strSL_Main = "SL_Date_ChLd"

strSL_ChLd = "SL_Date_Main"

Case Else

Call EventsChange(True)

Exit Sub

End Select

Call EventsChange(False)

'синхронизация по временной шкале

': StartDate : #01.09.2020# : Variant/Date

': EndDate : #30.09.2020# : Variant/Date

Set oSL_Main = ThisWorkbook.SlicerCaches(strSL_Main)

Set oSL = ThisWorkbook.SlicerCaches(strSL_ChLd)

Dim Lng_FilterType As Long

On Error GoTo Err_Slicer_FilterType

Lng_FilterType = oSL_Main.TimelineState.FilterType '(35)= xlDateBetween

Err_Slicer_FilterType:

If Lng_FilterType = 35 Then

Call oSL.TimelineState.SetFilterDateRange(oSL_Main.TimelineState.StartDate, oSL_Main.TimelineState.EndDate)

Else

ThisWorkbook.SlicerCaches(strSL_ChLd).ClearDateFilter

End If

'Синхронизировать срезы по списку значений

Call Me.SL_Main_VS_SL_ChLd("SL_Type_Main", "SL_Type_ChLd")

Call Me.SL_Main_VS_SL_ChLd("SL_Teinte_Main", "SL_Teinte_ChLd")

Call EventsChange(True)

End Sub

'\\Синхронизировать срезы

Sub SL_Main_VS_SL_ChLd(ByVal strSL_Main As String, _

ByVal strSL_ChLd As String)

Dim oSL_Main As SlicerCache '+ : oSL_MADC : : Variant/Object/SlicerCache

Dim oSL_ChLd As SlicerCache

Dim oVisibleSlicerItems As SlicerItem '+ : oVisibleSlicerItems : : Variant/Object/SlicerItem

On Error Resume Next

Set oSL_Main = ThisWorkbook.SlicerCaches(strSL_Main)

Set oSL_ChLd = ThisWorkbook.SlicerCaches(strSL_ChLd)

'сброс фильтра

oSL_ChLd.ClearManualFilter

For Each oVisibleSlicerItems In oSL_Main.SlicerItems

oSL_ChLd.SlicerItems(oVisibleSlicerItems.Name).Selected = oVisibleSlicerItems.Selected

' If oVisibleSlicerItems.Selected Then strItems = strItems & ";" & oVisibleSlicerItems.Value

Next

End Sub

'\\Выставить срез по списку значений

Sub SL_VaLue(ByVal oSL As SlicerCache, _

ByVal strValues As String)

Dim m As Variant, i As Long, strItem As String

On Error Resume Next

If Len(strValues) > 0 Then

oSL.ClearManualFilter

m = Split(strValues, ";", -1, vbTextCompare)

For Each oVisibleSlicerItems In oSL.VisibleSlicerItems

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

strItem = m(i)

Next i

If oVisibleSlicerItems.Value = strItem Then

oVisibleSlicerItems.Selected = True

Else

oVisibleSlicerItems.Selected = False

End If

Next

End If

End Sub

'\\список выбранных значений среза

Function fun_SL_strItems(ByVal strSL_Main As String) As String

Dim oSL_Main As SlicerCache

Dim oVisibleSlicerItems As SlicerItem

Set oSL_Main = ThisWorkbook.SlicerCaches(strSL_Main)

strItems = ""

For Each oVisibleSlicerItems In oSL_Main.VisibleSlicerItems

If oVisibleSlicerItems.Selected Then strItems = strItems & "; " & oVisibleSlicerItems.Value

Next

If Len(strItems) > 0 Then fun_SL_strItems = Right(strItems, Len(strItems) - 1)

End Function

'\\Пересчет сводных таблиц

Sub ManualUpdatePt(ByVal strShName As String, _

ByVal bVal As Boolean)

'strShName - имя листа

'bVal - включить\отключить

Dim oPt As PivotTable

On Error Resume Next

With ThisWorkbook.Sheets(strShName)

If .PivotTables.Count > 0 Then

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

oPt.ManualUpdate = bVal

Next 'oPt

End If

End With

' FnManualUpdatePt = True

End Sub

''тоже перехватывает... но PivotTableUpdate раньше.

'Private Sub Worksheet_PivotTableChangeSync(ByVal Target As PivotTable)

'End Sub

Private Sub Worksheet_PivotTableUpdate(ByVal Target As PivotTable)

' VBA ?? ????? dg_rusak@mail.ru

Dim strSL_Main As String, strSL_ChLd As String

strSL_Main = "SL_Date_Main"

Set oSL_Main = ThisWorkbook.SlicerCaches(strSL_Main)

'синхронизация по временной шкале

Call m_Change_Slicer.Change_Slicer_Date(oSL_Main.TimelineState.StartDate, oSL_Main.TimelineState.EndDate)

': StartDate : #01.09.2020# : Variant/Date

': EndDate : #30.09.2020# : Variant/Date

End Sub

Sub Change_Slicer_Date(ByVal strDateStart As String, ByVal strDateEnd As String)

Dim SlicerCaches As SlicerCaches

On Error Resume Next

Set oSL = ThisWorkbook.SlicerCaches("SL_Date_ChLd")

If Len(strDateStart) > 0 And Len(strDateEnd) > 0 Then

Call oSL.TimelineState.SetFilterDateRange(strDateStart, strDateEnd)

Else

' ThisWorkbook.SlicerCaches("____").ClearDateFilter

End If

End Sub