Option Explicit

Private m_oFlagCheckActiveWindow As Boolean

Public Property Let FlagCheckActiveWindow(bValue As Boolean)
    m_oFlagCheckActiveWindow = bValue
End Property
Public Property Get FlagCheckActiveWindow() As Boolean
    FlagCheckActiveWindow = m_oFlagCheckActiveWindow
End Property

Private Sub Workbook_Open()
    m_oFlagCheckActiveWindow = False
    
    PivotObj.EnableDrilldown = False
End Sub

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
    Dim oPivotDataRange As Excel.Range
    Dim oClickRange As Excel.Range
    
    Set oPivotDataRange = mdlPivotEdit.PivotDataRange()
    If (oPivotDataRange Is Nothing) Then
        Cancel = False
        Exit Sub
    End If
    
    If Not (Sh Is oPivotDataRange.Worksheet) Then
        Cancel = False
        Exit Sub
    End If
    
    Set oClickRange = Application.Intersect(oPivotDataRange, Target)
    If (oClickRange Is Nothing) Then
        Cancel = False
        Exit Sub
    End If
    
    mdlPivotEdit.DoEdit oClickRange.Cells(1)
     
    Cancel = True
End Sub

Private Sub Workbook_WindowActivate(ByVal Wn As Window)
    If Not FlagCheckActiveWindow Then Exit Sub
    
    If (Right(Wn.Caption, 2) = ":2") Then
        Windows(Left(Wn.Caption, Len(Wn.Caption) - 1) & "1").Close
        ActiveWindow.WindowState = xlMaximized
        
        PivotObj.RefreshTable
    End If
    
    FlagCheckActiveWindow = False
End Sub 

Option Explicit

Public Sub DoEdit(oClickCell As Excel.Range)
    Dim nDataCol As Long
    Dim oField As Excel.PivotField
    Dim oItem As Excel.PivotItem
    
On Error GoTo Err_
    ClearFilter_
    
    For Each oField In PivotObj.PageFields
        If IsValidPageField_(oField) Then
            AddFilter_ oField.SourceName, oField.CurrentPage.Name
        End If
    Next
    
    For Each oField In PivotObj.RowFields
        If IsValidDataField_(oField) Then
            If Not oField.IsCalculated Then
                For Each oItem In oField.PivotItems
                    If HasItemData_(oItem) Then
                        If Not (Application.Intersect(oClickCell, oItem.DataRange) Is Nothing) Then
                            AddFilter_ oField.SourceName, GetItemValue_(oItem)
                        End If
                    End If
                Next
            End If
        End If
    Next
    
    For Each oField In PivotObj.ColumnFields
        If Not (oField.Name = "Data") Then
            If Not oField.IsCalculated Then
                For Each oItem In oField.PivotItems
                    If HasItemData_(oItem) Then
                        If Not (Application.Intersect(oClickCell, oItem.DataRange) Is Nothing) Then
                            AddFilter_ oField.SourceName, GetItemValue_(oItem)
                        End If
                    End If
                Next
            End If
        End If
    Next
    
    For Each oField In PivotObj.DataFields
        If HasFieldData_(oField) Then
            If Not (Application.Intersect(oClickCell, oField.DataRange) Is Nothing) Then
                nDataCol = GetDataColumnByName_(oField.SourceName)
            End If
        End If
    Next
    
    ShowResult_ nDataCol
    
    Exit Sub
Err_:
End Sub

Public Function PivotObj() As Excel.PivotTable
    Set PivotObj = WorksheetPivotReport_.PivotTables(1)
End Function

Public Function PivotDataRange() As Excel.Range
    Set PivotDataRange = PivotObj.DataBodyRange
End Function

Public Function SourceDataRange() As Excel.Range
    Set SourceDataRange = Application.Range(Application.ConvertFormula(PivotObj.SourceData, xlR1C1, xlA1))
End Function

Public Function FilterDataRange() As Excel.Range
    Dim nColCount As Long
    
    nColCount = SourceDataRange.Columns.Count
    
    Set FilterDataRange = WorksheetFilter_.Range(WorksheetFilter_.Cells(1, 1), WorksheetFilter_.Cells(2, nColCount))
End Function


'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Private Function WorksheetPivotReport_() As Excel.Worksheet
    Set WorksheetPivotReport_ = ThisWorkbook.Worksheets("Отчет")
End Function

Private Function WorksheetData_() As Excel.Worksheet
    Set WorksheetData_ = ThisWorkbook.Worksheets("Data")
End Function

Private Function WorksheetFilter_() As Excel.Worksheet
On Error GoTo Err_
    Set WorksheetFilter_ = ThisWorkbook.Worksheets("Filter")
    Exit Function
Err_:
    Set WorksheetFilter_ = CreateFilterSheet_
End Function

Private Function CreateFilterSheet_() As Excel.Worksheet
    Dim oLastSheet As Object
    Dim oNewSheet As Excel.Worksheet
    Dim nCol As Long
    
    Set oLastSheet = Application.ActiveSheet
    
    Set oNewSheet = ThisWorkbook.Worksheets.Add(after:=WorksheetData_)
    oNewSheet.Name = "Filter"
    
    For nCol = 1 To SourceDataRange.Columns.Count
        oNewSheet.Cells(1, nCol) = SourceDataRange.Cells(1, nCol)
    Next
    
    oLastSheet.Activate
    
    Set CreateFilterSheet_ = oNewSheet
End Function

Private Function HasItemData_(oItem As Excel.PivotItem) As Boolean
On Error GoTo Err_
    'HasItemData_ = oItem.Visible And (oItem.RecordCount > 0) And Not (oItem.DataRange Is Nothing)
    HasItemData_ = (oItem.RecordCount > 0) And Not (oItem.DataRange Is Nothing)
    Exit Function
Err_:
    HasItemData_ = False
End Function

Private Function IsValidDataField_(oField As Excel.PivotField) As Boolean
    ' error checking only
On Error GoTo Err_
    IsValidDataField_ = (Not oField.IsCalculated) Or oField.IsCalculated
    Exit Function
Err_:
    IsValidDataField_ = False
End Function

Private Function IsValidPageField_(oField As Excel.PivotField) As Boolean
    ' error checking only
On Error GoTo Err_
    IsValidPageField_ = (Not oField.CurrentPage.IsCalculated) Or oField.CurrentPage.IsCalculated
    Exit Function
Err_:
    IsValidPageField_ = False
End Function

Private Function HasFieldData_(oField As Excel.PivotField) As Boolean
On Error GoTo Err_
    HasFieldData_ = Not (oField.DataRange Is Nothing)
    Exit Function
Err_:
    HasFieldData_ = False
End Function

Private Function GetItemValue_(oItem As Object) As Variant
    ' fix Excel 2007 bug
On Error GoTo Err_
    GetItemValue_ = oItem.SourceNameStandard
    Exit Function
Err_:
    GetItemValue_ = oItem.Value
End Function

Private Sub ClearFilter_()
    WorksheetFilter_.Rows(2).ClearContents
End Sub

Private Function GetDataColumnByName_(sName As String) As Long
    Dim nFirstCol As Long
    Dim nLastCol As Long
    Dim nHeaderRow As Long, nCol As Long
    
    nFirstCol = SourceDataRange.Cells(1).Column
    nLastCol = nFirstCol + SourceDataRange.Columns.Count - 1
    nHeaderRow = SourceDataRange.Cells(1).Row
    For nCol = nFirstCol To nLastCol
        If (WorksheetData_.Cells(nHeaderRow, nCol) = sName) Then
            GetDataColumnByName_ = nCol
            Exit Function
        End If
    Next
    
    GetDataColumnByName_ = 0
End Function

Private Function AddFilter_(sName As String, vValue As Variant) As Boolean
    Dim nLastCol As Long
    Dim nCol As Long
    
    nLastCol = SourceDataRange.Columns.Count
        
    For nCol = 1 To nLastCol
        If (WorksheetFilter_.Cells(1, nCol) = sName) Then
            WorksheetFilter_.Cells(2, nCol).Value = vValue
            
            AddFilter_ = True
            Exit Function
        End If
    Next
    AddFilter_ = False
End Function

Private Sub ShowResult_(nCol As Long)
    Dim oLastWindow As Excel.Window
    
    If (nCol = 0) Then Exit Sub
    
    ThisWorkbook.FlagCheckActiveWindow = False
    Set oLastWindow = ActiveWindow
    
    ActiveWindow.NewWindow
    ActiveWorkbook.Windows.Arrange ArrangeStyle:=xlHorizontal
    oLastWindow.Activate
    
    ThisWorkbook.FlagCheckActiveWindow = True
    
On Error Resume Next
    WorksheetData_.ShowAllData
On Error GoTo 0
    WorksheetData_.Activate
    
    SourceDataRange.AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:= _
        FilterDataRange, Unique:=False
       
    WorksheetData_.Range( _
                WorksheetData_.Cells(SourceDataRange.Cells(1).Row + 1, nCol), _
                WorksheetData_.Cells(SourceDataRange.Cells(SourceDataRange.Cells.Count).Row, nCol) _
                ).Select
    Selection.SpecialCells(xlCellTypeVisible).Select
End Sub