Как перейти к редактированию исходных данных прямо из сводной таблицы?

'---------------------------------------------------------------------------------------
' Author : Щербаков Дмитрий(The_Prist)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
' Purpose:
'---------------------------------------------------------------------------------------
Option Explicit
 
Sub EditPivotSource()
    Dim pt As PivotTable
    Dim wsDetails As Worksheet
    Dim rSource As Range, rDetails As Range
    Dim lAppCalc As Long
 
    Application.DisplayAlerts = False
    lAppCalc = Application.Calculation 'запоминаем установленный режим пересчета формул
    Application.Calculation = xlCalculationManual
    Application.ScreenUpdating = False
    On Error GoTo END_
 
    'определяем сводную таблицу и её исходные данные
    Set pt = ActiveCell.PivotTable
    Set rSource = Application.Evaluate(Application.ConvertFormula(pt.SourceData, xlR1C1, xlA1))
    'отображаем все данные в листе с исходными данными
    rSource.EntireRow.Hidden = False
    'разрешаем отображение деталей, если запрещено настройками
    '   Параметры сводной таблицы -Данные -Разрешить отображение деталей
    If Not pt.EnableDrilldown Then
        pt.EnableDrilldown = True
    End If
    'показываем лист с данными по выделенной области
    Selection.ShowDetail = True
    'запоминаем лист с деталями - потом надо будет удалить
    Set wsDetails = ActiveSheet
    Set rDetails = ActiveSheet.UsedRange
 
    rSource.AdvancedFilter xlFilterInPlace, rDetails
    'удаляем лист деталей - он больше не нужен
    wsDetails.Delete
    'активируем лист с исходными данными - теперь там отображены только нужные строки
    rSource.Parent.Activate
END_:
    If Err.Number <> 0 Then
        MsgBox "Выделите ячейку данных для редактирования", vbInformation, "www.excel-vba.ru"
    End If
    'возвращаем измененные настройки приложения в прежние значения
    Application.DisplayAlerts = True
    Application.Calculation = lAppCalc
    Application.ScreenUpdating = True
End Sub

'--------------------------------------------------------------------------------------- ' Author : Щербаков Дмитрий(The_Prist) ' Профессиональная разработка приложений для MS Office любой сложности ' Проведение тренингов по MS Excel ' https://www.excel-vba.ru ' info@excel-vba.ru ' Purpose: '--------------------------------------------------------------------------------------- Option Explicit Sub EditPivotSource() Dim pt As PivotTable Dim wsDetails As Worksheet Dim rSource As Range, rDetails As Range Dim lAppCalc As Long Application.DisplayAlerts = False lAppCalc = Application.Calculation 'запоминаем установленный режим пересчета формул Application.Calculation = xlCalculationManual Application.ScreenUpdating = False On Error GoTo END_ 'определяем сводную таблицу и её исходные данные Set pt = ActiveCell.PivotTable Set rSource = Application.Evaluate(Application.ConvertFormula(pt.SourceData, xlR1C1, xlA1)) 'отображаем все данные в листе с исходными данными rSource.EntireRow.Hidden = False 'разрешаем отображение деталей, если запрещено настройками ' Параметры сводной таблицы -Данные -Разрешить отображение деталей If Not pt.EnableDrilldown Then pt.EnableDrilldown = True End If 'показываем лист с данными по выделенной области Selection.ShowDetail = True 'запоминаем лист с деталями - потом надо будет удалить Set wsDetails = ActiveSheet Set rDetails = ActiveSheet.UsedRange rSource.AdvancedFilter xlFilterInPlace, rDetails 'удаляем лист деталей - он больше не нужен wsDetails.Delete 'активируем лист с исходными данными - теперь там отображены только нужные строки rSource.Parent.Activate END_: If Err.Number <> 0 Then MsgBox "Выделите ячейку данных для редактирования", vbInformation, "www.excel-vba.ru" End If 'возвращаем измененные настройки приложения в прежние значения Application.DisplayAlerts = True Application.Calculation = lAppCalc Application.ScreenUpdating = True End Sub

'---------------------------------------------------------------------------------------
' Author : Щербаков Дмитрий(The_Prist)
'          Профессиональная разработка приложений для MS Office любой сложности
'          Проведение тренингов по MS Excel
'          https://www.excel-vba.ru
'          info@excel-vba.ru
' Purpose: Обработка двойного клика мыши в сводной таблице
'          и переход к сводной после редактирования источника данных
'
'          Так же при открытии книги создается пункт в меню правой кнопки мыши сводной - Edit Source
'          и удаляется перед закрытием этой книги
'---------------------------------------------------------------------------------------
Option Explicit
 
'при активации листа со сводной таблицей - обновляем все сводные
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
    Dim pt As PivotTable
    'обновляем все сводные таблицы на листе, на который перешли
    For Each pt In Sh.PivotTables
        pt.PivotCache.Refresh
    Next
End Sub
 
'обрабатываем двойной клик мыши внутри сводной таблицы
Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim rcPT As PivotTable
    'проверяем, является ли ячейка,
    'на которой дважды щелкнули мышью
    'ячейкой внутри сводной таблицы
    On Error Resume Next
    Set rcPT = Target.PivotTable
    On Error GoTo 0
    'если это ячейка сводной
    If Not rcPT Is Nothing Then
        'вызываем процедуру фильтрации источника данных
        EditPivotSource
        Cancel = True
    End If
End Sub
 
'================================================================================
'              СОЗДАНИЕ И УДАЛЕНИЕ ПУНКТА МЕНЮ В СВОДНОЙ
'
'добавляем в меню сводных таблиц пункт "Edit Source",
'который будет отбирать данные непосредственно в источнике данных
Private Sub Workbook_Open()
    Dim bt As CommandBarControl, indx As Long
 
    On Error Resume Next
    'ищем пункт меню "Показать детали"
    Set bt = Application.CommandBars("PivotTable Context Menu").FindControl(ID:=462)
    'если нашли - добавим после него новый пункт "Edit source"
    '   при нажатии которого будет вызываться наш код перехода к источнику
    'если не нашли - ставим вторым пунктом
    If Not bt Is Nothing Then
        indx = bt.Index
    Else
        indx = 1
    End If
    'пробуем удалить пункт "Edit source", если он ранее был создан
    'чтобы не было задвоения
    Application.CommandBars("PivotTable Context Menu").Controls("Edit source").Delete
    'добавляем новый пункт
    With Application.CommandBars("PivotTable Context Menu").Controls.Add(before:=indx + 1)
        .Caption = "Edit source"
        .OnAction = "'" & ThisWorkbook.Name & "'!EditPivotSource"
    End With
End Sub
 
'перед закрытием книги удаляем созданный нами пункт меню
Private Sub Workbook_BeforeClose(Cancel As Boolean)
    On Error Resume Next
    Application.CommandBars("PivotTable Context Menu").Controls("Edit source").Delete
End Sub
'================================================================================

'--------------------------------------------------------------------------------------- ' Author : Щербаков Дмитрий(The_Prist) ' Профессиональная разработка приложений для MS Office любой сложности ' Проведение тренингов по MS Excel ' https://www.excel-vba.ru ' info@excel-vba.ru ' Purpose: Обработка двойного клика мыши в сводной таблице ' и переход к сводной после редактирования источника данных ' ' Так же при открытии книги создается пункт в меню правой кнопки мыши сводной - Edit Source ' и удаляется перед закрытием этой книги '--------------------------------------------------------------------------------------- Option Explicit 'при активации листа со сводной таблицей - обновляем все сводные Private Sub Workbook_SheetActivate(ByVal Sh As Object) Dim pt As PivotTable 'обновляем все сводные таблицы на листе, на который перешли For Each pt In Sh.PivotTables pt.PivotCache.Refresh Next End Sub 'обрабатываем двойной клик мыши внутри сводной таблицы Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean) Dim rcPT As PivotTable 'проверяем, является ли ячейка, 'на которой дважды щелкнули мышью 'ячейкой внутри сводной таблицы On Error Resume Next Set rcPT = Target.PivotTable On Error GoTo 0 'если это ячейка сводной If Not rcPT Is Nothing Then 'вызываем процедуру фильтрации источника данных EditPivotSource Cancel = True End If End Sub '================================================================================ ' СОЗДАНИЕ И УДАЛЕНИЕ ПУНКТА МЕНЮ В СВОДНОЙ ' 'добавляем в меню сводных таблиц пункт "Edit Source", 'который будет отбирать данные непосредственно в источнике данных Private Sub Workbook_Open() Dim bt As CommandBarControl, indx As Long On Error Resume Next 'ищем пункт меню "Показать детали" Set bt = Application.CommandBars("PivotTable Context Menu").FindControl(ID:=462) 'если нашли - добавим после него новый пункт "Edit source" ' при нажатии которого будет вызываться наш код перехода к источнику 'если не нашли - ставим вторым пунктом If Not bt Is Nothing Then indx = bt.Index Else indx = 1 End If 'пробуем удалить пункт "Edit source", если он ранее был создан 'чтобы не было задвоения Application.CommandBars("PivotTable Context Menu").Controls("Edit source").Delete 'добавляем новый пункт With Application.CommandBars("PivotTable Context Menu").Controls.Add(before:=indx + 1) .Caption = "Edit source" .OnAction = "'" & ThisWorkbook.Name & "'!EditPivotSource" End With End Sub 'перед закрытием книги удаляем созданный нами пункт меню Private Sub Workbook_BeforeClose(Cancel As Boolean) On Error Resume Next Application.CommandBars("PivotTable Context Menu").Controls("Edit source").Delete End Sub '================================================================================