Pivot Table - DrillDown

anastasia

New Member
Joined
Feb 24, 2006
Messages
2
Evening

Hoping someone can point me in the right direction.

I have my source data in "Source"
I have my pivot table in "Pivot"
I have created a separate worksheet called "DrillDown"

When I double click on a cell in "Pivot", is it possible to display the drilldown data in "DrillDown"?
Excel seems to populate it in a new worksheet every time a user drills down. **** annoying to delete each worksheet after looking at the data!

Please help!

Thanks
Anastasia[/b]
 
Re: Pivot Table - DrillDown - possibly one for VBA gurus

Been trying this but cant get it to function, is there any chance to can post a working example.
 
Upvote 0

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
Re: Pivot Table - DrillDown - possibly one for VBA gurus

I know this is an old thread, but I found it useful and this is the code I came up with.
Remember that the module name must be WB_ThisWorkbook (and that some subs name and parameters cannot be changed either).

Code:
Option Explicit
'
'F: This entire module should be copied into an Excel workbook in the WB_ThisWorkbook module.
'   This code was inspired by:
'      http://www.mrexcel.com/forum/excel-questions/190025-pivot-table-drilldown-possibly-one-visual-basic-applications-gurus.html.
'
'   A standard feature of pivot tables is "Show Details".
'   If a pivot table has PivotTable options | Data | "Enable Show Details" on then:
'      double click
'   or
'      right click | Show Details
'   to copy the data behind that cell into a new detail (or drilldown) worksheet.
'
'   A workbook can quickly become cluttered with drilldown sheets and it is not immediately apparent
'   where the data came from.
'
'   In my application, the pivot details are a summary of another sheet.
'
'   If the pivot table sheet name ends in "_Pivot", then:
'       a single drilldown sheet per pivot sheet is used.
'       the drilldown sheet name has "_Pivot" replaced by "_DD".
'       a header describes where the data came from.
'       the drilldown sheet has frozen columns as per the data source
'           (not the pivot table - the source of the pivot).
'       the drilldown data is sorted in the frozen columns
'           as expect the source data is sorted in frozen columns.
'       if a drilldown cell in the leftmost column is clicked, the data range in Milestone_Detail is highlighted.
'           actual name is in the constant strDetail_Sheet.
'       if other than the left most column is clicked, and it is non blank, deletion of that range of details is offered.
'       simply change the pivot table sheet name if you don't like this. (I use a dot at the end.)
'
'   This code handles multiple pivot tables (each in its own sheet).
'
' Directory
' =========
' Workbook_NewSheet
' Workbook_NewSheet_A
' Workbook_SheetBeforeDoubleClick
' SheetExists
' FindAll
' FindAll_Test
' Sort_Rows
'
Public xlrngCurrent         As Excel.Range
Const strTagDrillDown       As String = "_DD"
Const strTagPivot           As String = "_Pivot"
' Const blnUse_SheetName      As Boolean = False ' Use Pivot Table name.
Const blnUse_SheetName      As Boolean = True ' Use Sheet name.
Const strDetail_Sheet       As String = "Milestone_Detail"
Const intDebug              As Integer = 0 ' No debugging.
' Const intDebug              As Integer = 1 ' Standard debugging.
' Const intDebug              As Integer = 2 ' Detailed debugging.

Public Sub Workbook_NewSheet(ByVal Sh As Object)
'
' F: Excel event procedure run after new sheet is created.
'    Must reside in ThisWorkbook module of an Excel workbook to function.
'    Name cannot be changed.
'    Signature cannot be changed.
'       Stated another way: Parameter declarations cannot be changed in any way.
'
'    Jacket for Workbook_NewSheet_A.
'
' I: Sh                     New sheet.
'
Dim xlrngActiveCell         As Excel.Range
Dim strDetail               As String
Const strWho                As String = "Workbook_NewSheet"

If intDebug >= 2 Then
    Debug.Print strWho & "  ActiveSheet.Name=" & ActiveSheet.Name
    Debug.Print strWho & "    New Sheet.Name=" & Sh.Name
    End If
If intDebug >= 2 Then
    On Error Resume Next
    Debug.Print strWho & " " & xlrngCurrent.Address(External:=True)
    Set xlrngActiveCell = ActiveCell
    Debug.Print strWho & " ActiveCell.Address=" & xlrngActiveCell.Address(External:=True)
    ' These pivot attributes will be invalid since they point to a new sheet.
    strDetail = ActiveCell.PivotCell.ColumnItems.Item(1).DataRange
        If Err.Number <> 0 Then strDetail = "<null>"
    Debug.Print strWho & " PivotCell.ColumnItems.DataRange=" & strDetail
        If Err.Number <> 0 Then strDetail = "<null>"
    strDetail = ActiveCell.PivotCell.ColumnItems.Item(1).ParentItem.Caption
        If Err.Number <> 0 Then strDetail = "<null>"
    Debug.Print strWho & " PivotCell.ParentItem.Caption=" & strDetail
    strDetail = xlrngActiveCell.PivotItem.Name
        If Err.Number <> 0 Then strDetail = "<null>"
    Debug.Print strWho & " PivotItem=" & strDetail
    strDetail = xlrngActiveCell.PivotField.Name
        If Err.Number <> 0 Then strDetail = "<null>"
    Debug.Print strWho & " PivotField=" & strDetail
    strDetail = xlrngActiveCell.PivotTable.Name
        If Err.Number <> 0 Then strDetail = "<null>"
    Debug.Print strWho & " PivotTable=" & strDetail
    On Error GoTo 0
    End If

Call Workbook_NewSheet_A(Sh:=Sh)
End Sub ' Workbook_NewSheet.

Public Sub Workbook_NewSheet_A(ByVal Sh As Object)
'
' F: When a cell in a pivot table is double clicked, Excel:
'       creates a new sheet
'       copies the data that is behind the pivotcell to the new sheet
'           Code here calls the new sheet the Drilldown sheet.
'       invokes Workbook_NewSheet VBA subroutine:
'           That subroutine calls this code.
'           This code creates the Drilldown sheet if required (and copies frozen columns specification).
'           This code copies and sorts the data to the Drilldown sheet.
'           This code deletes the new sheet.
'
'    When VBA deletes the new sheet, then Excel, by default, returns to the sheet it was in previously,
'    i.e. the one you double clicked in.
'
'    From:
'       http://www.mrexcel.com/forum/excel-questions/190025-pivot-table-drilldown-possibly-one-visual-basic-applications-gurus.html
'
' G: xlrngCurrent           See Workbook_SheetBeforeDoubleClick.
'
Dim xlrngActiveCell         As Excel.Range
Dim numBang                 As Long
Dim strClickedSheet         As String
Dim numCol_Criteria         As Integer
Dim strDrillDown            As String          ' Accumulated drill downs.
Dim xlwsDrillDown           As Excel.Worksheet ' Accumulated drill downs.
Dim numI                    As Integer
Dim xlwsNascentSheet        As Excel.Worksheet ' The just created sheet.
Dim xlpvcPivotCell          As Excel.PivotCell
Dim blnPivotSheet           As Boolean
Dim numRow_Criteria         As Integer
Dim numRows                 As Long
Dim xlwsSourceSheet         As Excel.Worksheet
Dim numSplitColumn          As Long
Dim numSplitRow             As Long
Dim strWhere_From           As String
Dim y(1 To 3)               As Integer
Const strWho                As String = "Workbook_NewSheet_A"
'˜Const intDebug              As Integer = 2 ' If commented, use global.

If xlrngCurrent Is Nothing Then
    Exit Sub
    End If
strClickedSheet = xlrngCurrent.Parent.Name ' Sheet when clicked via global. See Workbook_SheetBeforeDoubleClick.
If strClickedSheet <> "" Then
    Set xlwsNascentSheet = ActiveSheet
    If blnUse_SheetName Then
        If Right(strClickedSheet, Len(strTagPivot)) = strTagPivot Then
            blnPivotSheet = True
            End If
    Else
        If strClickedSheet = xlrngCurrent.PivotTable.Name Then
            If strClickedSheet <> "" Then
                blnPivotSheet = True
            Else
                blnPivotSheet = False
                End If
            End If
        End If
    If intDebug >= 2 Then
        Debug.Print strWho & ": blnPivotSheet=" & blnPivotSheet
        End If
    If Not blnPivotSheet Then
        Set xlrngCurrent = Nothing
        Exit Sub
        End If
    ' Given the sheetname-when-clicked, get drilldown sheet name.
    strDrillDown = Left(strClickedSheet, Len(strClickedSheet) - Len(strTagPivot)) & strTagDrillDown
    If intDebug >= 2 Then
        Debug.Print strWho & " DrillDown=" & strDrillDown
        End If
    With ActiveSheet.Application
        If intDebug >= 2 Then
            Debug.Print strWho & ": SourceName=" & xlrngCurrent.PivotCell.DataField.SourceName
            Debug.Print strWho & ": SourceData=" & xlrngCurrent.PivotCell.PivotTable.SourceData
            End If
        ' Get source sheet so can freeze/sort columns on the Drilldown.
        numBang = InStr(1, xlrngCurrent.PivotCell.PivotTable.SourceData, "!")
        Set xlwsSourceSheet = .Worksheets(Left(xlrngCurrent.PivotCell.PivotTable.SourceData, numBang - 1))
        .ScreenUpdating = False
        If SheetExists(strWorksheet:=strDrillDown) Then
            Set xlwsDrillDown = .Sheets(strDrillDown)
        Else
            ' Need to be careful:
            '    we are here because a new sheet, the nascent sheet, has been added.
            '    we do not have a drilldown sheet.
            '    we want to add a new sheet (for the drill down), but we don't want this very code to run
            '    for that sheet.
            ' Therefore, disable events and reenable after adding the sheet.
            .EnableEvents = False
            Set xlwsDrillDown = ActiveSheet.Application.Sheets.Add(After:=Sheets(strClickedSheet))
            ' Reenable.
            .EnableEvents = True
            xlwsDrillDown.Name = strDrillDown
            ' Transfer frozen columns.
            xlwsSourceSheet.Activate ' Activate the source sheet of the clicked sheet.
            With ActiveWindow
                If (.SplitRow = 0) And (.SplitColumn = 0) Then
                    ' Nothing to do - not frozen.
                Else
                    numSplitColumn = .SplitColumn
                    numSplitRow = .SplitRow
                    xlwsDrillDown.Activate
                    With ActiveWindow
                        .SplitColumn = numSplitColumn
                        .SplitRow = numSplitRow
                        .FreezePanes = True
                        End With
                    End If
                End With
            End If
        With xlwsDrillDown
            If WorksheetFunction.CountA(.Rows(1)) = 0 Then
                numRows = 1
            Else
                numRows = .Cells.Find(What:="*", _
                                      After:=[A1], _
                                      SearchOrder:=xlByRows, _
                                      SearchDirection:=xlPrevious).Row + 2
                End If
            If False Then
                xlwsNascentSheet.Range("A1").CurrentRegion.Copy Destination:=.Cells(numRows, 1)
            Else
                xlwsNascentSheet.Range("A1").CurrentRegion.Copy
                With xlwsDrillDown.Cells(numRows, 1)
                   .PasteSpecial Paste:=xlPasteAllUsingSourceTheme
                   .PasteSpecial Paste:=xlPasteColumnWidths
                   End With
                With .Cells(numRows, 1) _
                        .Resize(RowSize:=xlwsNascentSheet.Range("A1").CurrentRegion.Rows.Count, _
                                ColumnSize:=xlwsNascentSheet.Range("A1").CurrentRegion.Columns.Count)
                    xlwsSourceSheet.Activate ' Activate the source sheet of the clicked sheet.
                    If ActiveWindow.SplitColumn > 0 Then
                        'Stop
                        Sort_Rows numColumns:=ActiveWindow.SplitColumn - 1, _
                                  numLeft_Column:=1, _
                                  xlrngTarget:=.CurrentRegion ' Includes header.
                        End If
                    End With
                End If
            If intDebug >= 1 Then
                Debug.Print strWho & " CurrentRegion.Address=" & _
                            xlwsNascentSheet.Range("A1").CurrentRegion.Address(External:=True)
                End If
            End With

        .DisplayAlerts = False
        xlwsNascentSheet.Delete
        .DisplayAlerts = True

        Set xlrngActiveCell = xlrngCurrent ' Copy global, which cannot be seen in debugger, to local, which can.
        If intDebug >= 1 Then
            Debug.Print strWho & " xlrngCurrent.Address=" & xlrngCurrent.Address(External:=True)
            Debug.Print strWho & " xlrngActiveCell.Address=" & xlrngActiveCell.Address(External:=True)
            End If
        Set xlpvcPivotCell = xlrngCurrent.PivotCell
        numCol_Criteria = xlpvcPivotCell.ColumnItems.Count
        numRow_Criteria = xlpvcPivotCell.RowItems.Count
        If intDebug >= 1 Then
            Debug.Print strWho & " Row_Criteria=" & numRow_Criteria & " Col_Criteria=" & numCol_Criteria
            Debug.Print strWho & " .ColumnItems(1)=" & xlrngCurrent.PivotCell.ColumnItems.Item(1).Name
            End If

        strWhere_From = ""
        If numRow_Criteria > 0 Then
            strWhere_From = strWhere_From & " Row"
            For numI = 1 To numRow_Criteria
                strWhere_From = strWhere_From & " [" & xlpvcPivotCell.RowItems.Item(numI) & "]"
                Next numI
            End If
        y(1) = Len(strWhere_From)

        If numCol_Criteria > 0 Then
            strWhere_From = strWhere_From & " / Column"
            For numI = 1 To numCol_Criteria
                strWhere_From = strWhere_From & " [" & xlpvcPivotCell.ColumnItems.Item(numI) & "]"
                Next numI
            End If
        y(2) = Len(strWhere_From)

        strWhere_From = strWhere_From & " from Sheet " & ActiveSheet.Name
        y(3) = Len(strWhere_From)

        xlwsDrillDown.Select

        xlwsDrillDown.Cells(numRows, 1).EntireRow.Interior.ColorIndex = xlColorIndexNone
        xlwsDrillDown.Cells(numRows, 1).EntireRow.Select
        Selection.Insert Shift:=xlDown
        ActiveCell.Value = strWhere_From

        With ActiveCell.Characters.Font
            .Name = "Arial"
            .FontStyle = "Bold Italic"
            .Size = 12
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            .TintAndShade = 0
            .ThemeFont = xlThemeFontNone
            End With
        
        With ActiveCell.Characters(Start:=1, Length:=y(1)).Font
            .Color = -16776961 ' Red=255, Green=1, Blue=1. - Port.
            End With

        With ActiveCell.Characters(Start:=y(1) + 1, Length:=y(2) - y(1)).Font
            .Color = -11489280 ' Red=0, Green=176, Blue=81. - Starboard.
            End With

        With ActiveCell.Characters(Start:=y(2) + 1, Length:=y(3) - y(2)).Font
            .Color = -4165632 ' Red=0, Green=112, Blue=193.
            End With
        .ScreenUpdating = True
        End With
    End If
Set xlrngCurrent = Nothing
End Sub ' Workbook_NewSheet_A.

Private Sub Workbook_SheetBeforeDoubleClick(ByVal Sh As Object, ByVal Target As Range, Cancel As Boolean)
'
' F: Excel event procedure for any worksheet in workbook before double click.
'    Must reside in ThisWorkbook module of an Excel workbook to function.
'    Name cannot be changed.
'    Signature cannot be changed.
'
' G: xlrngCurrent
'
Dim intCancel               As Integer
Dim blnDrillDownSheet       As Boolean
Dim intErr_Number           As Integer
Dim xlrngFound              As Excel.Range
Dim strPivotTable           As String
Dim xlrngSearch             As Excel.Range
Dim strValue                As String
Const strWho                As String = "Workbook_SheetBeforeDoubleClick"
' Const intDebug              As Integer = 1 ' If commented, use global.

Set xlrngCurrent = Nothing ' Make sure no dangling reference.
If Right(Target.Parent.Name, Len(strTagDrillDown)) = strTagDrillDown Then
    blnDrillDownSheet = True
    End If
If intDebug >= 1 Then
    Debug.Print strWho & ": Target.Address=" & Target.Address(External:=True)
    Debug.Print strWho & ": ActiveCell.Address=" & ActiveCell.Address(External:=True)
    Debug.Print strWho & ": blnDrillDownSheet=" & blnDrillDownSheet
    End If
If blnDrillDownSheet Then
    If ActiveCell.Column = 1 Then
        ' Left-most column on drilldown sheet.
        ' Find history of summary item.
        If strDetail_Sheet = "" Then
            Exit Sub
            End If
        strValue = ActiveCell.Value
        If SheetExists(strWorksheet:=strDetail_Sheet) Then
            Set xlrngSearch = Range(strDetail_Sheet)
        Else
            ActiveCell.Application.StatusBar = "Sheet " & strDetail_Sheet & " does not exist"
            Exit Sub
            End If
        If intDebug >= 2 Then
            Debug.Print strWho & ": Search.Address=" & xlrngSearch.Address(External:=True)
            Debug.Print strWho & ": Search.Address=" & xlrngSearch.Resize(ColumnSize:=1).Address(External:=True)
            End If
        Set xlrngFound = FindAll(SearchRange:=xlrngSearch.Resize(ColumnSize:=1), _
                                 FindWhat:=strValue, _
                                 LookIn:=xlValues, _
                                 LookAt:=xlWhole, _
                                 SearchOrder:=xlByColumns, _
                                 MatchCase:=False, _
                                 BeginsWith:=vbNullString, _
                                 EndsWith:=vbNullString, _
                                 BeginEndCompare:=vbTextCompare, _
                                 intDebug:=intDebug)
        If xlrngFound Is Nothing Then
            If intDebug >= 1 Then
                Debug.Print strWho & ": Value Not Found=""" & strValue & """"
                End If
        Else
            If intDebug >= 1 Then
                Debug.Print strWho & ": Found.Address=" & xlrngFound.Address(External:=True)
                End If
            xlrngFound.Application.Goto _
                Reference:=xlrngFound.Resize(ColumnSize:=xlrngSearch.Columns.Count), _
                scroll:=True
            End If
        Exit Sub
        End If
    If ActiveCell.Value <> "" Then
        intCancel = MsgBox("Delete this detailed data?", vbYesNo)
        If intCancel = vbNo Then
            ' Keep the data.
            Exit Sub
            End If
        ' Delete region.
        With Target.CurrentRegion
            .Resize(.Rows.Count + 1).EntireRow.Delete
            End With
        End If
    If intDebug >= 2 Then
       Debug.Print strWho & ": Old Selection.Address=" & Selection.Address(External:=True)
       End If
    If intDebug >= 1 Then
       Debug.Print strWho & ": New Selection.Address=" & Selection.Address(External:=True)
       End If
Else
    ' Not a drilldown sheet.
    On Error Resume Next
    strPivotTable = Target.PivotTable.Name
    On Error GoTo 0
    If strPivotTable <> "" Then
        ' Within a pivot table.
        If blnUse_SheetName Then
            If Right(Target.Parent.Name, Len(strTagPivot)) = strTagPivot Then
                ' Save target in a global variable, so enable detail processing.
                Set xlrngCurrent = Target
                End If
        Else
            Set xlrngCurrent = Target ' Save target in a global variable, so enable detail processing.
            End If
        ' After the doubleclick (a.k.a. the reason for being in this sub), Excel will create a new
        ' sheet and call Workbook_NewSheet.
        End If
    End If
End Sub ' Workbook_SheetBeforeDoubleClick.

Function SheetExists(strWorksheet As String, Optional xlWbWorkBook As Excel.Workbook = Nothing) As Boolean
'
' F: Checks whether a worksheet exists.
'    From:
'       http://stackoverflow.com/questions/11776353/rename-worksheet-name-based-on-pivot-drill-with-vba.
'
' I: strWorksheet           Worksheet name to check.
'    xlWbWorkBook           Workbook to check. Defaults to ThisWorkbook.
'
' O: <result>
'       True => Exists
'
SheetExists = False
Dim xlwsWorkSheet           As Excel.Worksheet

If xlWbWorkBook Is Nothing Then Set xlWbWorkBook = ThisWorkbook

On Error Resume Next
Set xlwsWorkSheet = xlWbWorkBook.Worksheets(strWorksheet)
On Error GoTo 0

If Not xlwsWorkSheet Is Nothing Then SheetExists = True

End Function ' SheetExists.

Function FindAll(SearchRange As Range, _
                 FindWhat As Variant, _
                 Optional LookIn As Excel.XlFindLookIn = xlValues, _
                 Optional LookAt As Excel.XlLookAt = xlWhole, _
                 Optional SearchOrder As Excel.XlSearchOrder = xlByRows, _
                 Optional MatchCase As Boolean = False, _
                 Optional BeginsWith As String = vbNullString, _
                 Optional EndsWith As String = vbNullString, _
                 Optional BeginEndCompare As VbCompareMethod = vbTextCompare, _
                 Optional intDebug As Integer = 1) As Range
'
' F: This searches the range specified by SearchRange and returns a Range object that contains all the
'    cells in which FindWhat was found.
'    The search parameters to this function have the same meaning and effect as they do with the
'    Range.Find method.
'    If the value was not found, the function returns Nothing.
'    If BeginsWith is not an empty string, only those cells that begin with BeginsWith are included in
'    the result.
'    If EndsWith is not an empty string, only those cells that end with EndsWith are included in the
'    result.
'    Note that if a cell contains a single word that matches either BeginsWith or EndsWith, it is
'    included in the result.
'    If BeginsWith or EndsWith is not an empty string, the LookAt parameter is automatically changed to
'    xlPart.
'    The tests for BeginsWith and EndsWith may be case-sensitive by setting BeginEndCompare to
'    vbBinaryCompare.
'    For case-insensitive comparisons, set BeginEndCompare to vbTextCompare.
'    If this parameter is omitted, it defaults to vbTextCompare.
'    The comparisons for BeginsWith and EndsWith are in an OR relationship. That is, if both BeginsWith
'    and EndsWith are provided, a match if found if the text begins with BeginsWith OR the text ends
'    with EndsWith.
'
'    From:
'       http://www.cpearson.com/excel/FindAll.aspx.
'
' T: FindAll_Test
'
Dim FoundCell               As Excel.Range
Dim FirstFound              As Excel.Range
Dim LastCell                As Excel.Range
Dim ResultRange             As Excel.Range
Dim XLookAt                 As Excel.XlLookAt
Dim Include                 As Boolean
Dim CompMode                As VbCompareMethod
Dim Area                    As Excel.Range
Dim MaxRow                  As Long
Dim MaxCol                  As Long
Dim BeginB                  As Boolean
Dim EndB                    As Boolean
Const strWho                As String = "FindAll"

CompMode = BeginEndCompare
If BeginsWith <> vbNullString Or EndsWith <> vbNullString Then
    XLookAt = xlPart
Else
    XLookAt = LookAt
    End If

' This loop in Areas is to find the last cell of all the areas.
' That is, the cell whose row and column are greater than or equal to any cell in any Area.

For Each Area In SearchRange.Areas
    With Area
        If .Cells(.Cells.Count).Row > MaxRow Then
            MaxRow = .Cells(.Cells.Count).Row
            End If
        If .Cells(.Cells.Count).Column > MaxCol Then
            MaxCol = .Cells(.Cells.Count).Column
            End If
        End With
    Next Area
Set LastCell = SearchRange.Worksheet.Cells(MaxRow, MaxCol)

On Error GoTo 0
Set FoundCell = SearchRange.Find(What:=FindWhat, _
                                 After:=LastCell, _
                                 LookIn:=LookIn, _
                                 LookAt:=XLookAt, _
                                 SearchOrder:=SearchOrder, _
                                 MatchCase:=MatchCase)

If Not FoundCell Is Nothing Then
    Set FirstFound = FoundCell
    If intDebug >= 1 Then
        Debug.Print strWho & " FirstFound.Address=" & FirstFound.Address(External:=True)
        End If
    Do Until False ' Loop forever. We'll "Exit Do" when necessary.
        Include = False
        If BeginsWith = vbNullString And EndsWith = vbNullString Then
            Include = True
        Else
            If BeginsWith <> vbNullString Then
                If StrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0 Then
                    Include = True
                    End If
                End If
            If EndsWith <> vbNullString Then
                If StrComp(Right(FoundCell.Text, Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                    Include = True
                    End If
                End If
            End If
        If Include = True Then
            If ResultRange Is Nothing Then
                Set ResultRange = FoundCell
            Else
                Set ResultRange = SearchRange.Application.Union(ResultRange, FoundCell)
                End If
            End If
        Set FoundCell = SearchRange.FindNext(After:=FoundCell)
        If (FoundCell Is Nothing) Then
            Exit Do
            End If
        If (FoundCell.Address = FirstFound.Address) Then
            Exit Do
            End If

        Loop
    End If
    
Set FindAll = ResultRange

End Function ' FindAll.

Sub FindAll_Test()
'
' F: Test for FindAll.
'
' T: FindAll_Test
'
Dim SearchRange             As Excel.Range
Dim FindWhat                As Variant
Dim FoundCells              As Excel.Range
Dim FoundCell               As Excel.Range
Const strWho                As String = "FindAll_Test"
Const intDebug              As Integer = 1

Set SearchRange = Range(strDetail_Sheet & "!A1:A40")
If intDebug >= 1 Then
    Debug.Print strWho & " SearchRange.Address=" & SearchRange.Address(External:=True)
    End If
FindWhat = "Test-Target"
Set FoundCells = FindAll(SearchRange:=SearchRange, _
                         FindWhat:=FindWhat, _
                         LookIn:=xlValues, _
                         LookAt:=xlWhole, _
                         SearchOrder:=xlByColumns, _
                         MatchCase:=False, _
                         BeginsWith:=vbNullString, _
                         EndsWith:=vbNullString, _
                         BeginEndCompare:=vbTextCompare, _
                         intDebug:=intDebug)
If FoundCells Is Nothing Then
    Debug.Print "Value Not Found"
Else
    For Each FoundCell In FoundCells
        Debug.Print "Value Found In Cell: " & FoundCell.Address(False, False)
        Next FoundCell
    End If

End Sub ' FindAll_Test.

Function Sort_Rows(numColumns As Integer, numLeft_Column As Long, xlrngTarget As Excel.Range) As Boolean
'
' F: Sorts a range by columns.
'    For simplicity, columns are contiguous.
'    Handles upto and including 5 keys.
'
' I: numColumns             Number of columns to sort.
'    numLeft_Column         Left column for sort.
'    xlrngTarget            Range to sort.
'
' O: <result>               Error indicator.
'       True => Error.
'
Const strWho                As String = "Sort_Rows"

If intDebug >= 1 Then
    Debug.Print strWho & ": Target.Address=" & xlrngTarget.Address(External:=True)
    Debug.Print strWho & ": Target.Columns(Left_Column).Address=" & xlrngTarget.Columns(numLeft_Column + 0).Address(External:=True)
    End If
'xlrngTarget.Sort key1:=xlrngTarget.Columns(numLeft_Column).Resize(ColumnSize:=numColumns), order1:=xlAscending, Header:=xlYes
With xlrngTarget
    If numColumns = 1 Then
        .Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, Header:=xlYes
    ElseIf numColumns = 2 Then
        .Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, _
              key2:=.Columns(numLeft_Column + 1), order2:=xlAscending, _
              Header:=xlYes
    ElseIf numColumns = 3 Then
        .Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, _
              key2:=.Columns(numLeft_Column + 1), order2:=xlAscending, _
              key3:=.Columns(numLeft_Column + 2), order3:=xlAscending, _
              Header:=xlYes
    ElseIf numColumns = 4 Then
        ' Since sort is stable, can sort by the fourth key and then the other three.
        .Sort key1:=.Columns(numLeft_Column + 3), order1:=xlAscending, Header:=xlYes
        .Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, _
              key2:=.Columns(numLeft_Column + 1), order2:=xlAscending, _
              key3:=.Columns(numLeft_Column + 2), order3:=xlAscending, _
              Header:=xlYes
    ElseIf numColumns = 5 Then
        ' Since sort is stable, can sort by the fourth and fifth keys and then the other three.
        .Sort key1:=.Columns(numLeft_Column + 3), order1:=xlAscending, _
              key2:=.Columns(numLeft_Column + 4), order2:=xlAscending, _
              Header:=xlYes
        .Sort key1:=.Columns(numLeft_Column + 0), order1:=xlAscending, _
              key2:=.Columns(numLeft_Column + 1), order2:=xlAscending, _
              key3:=.Columns(numLeft_Column + 2), order3:=xlAscending, _
              Header:=xlYes
    Else
        MsgBox Prompt:=strWho & ": Too many sort keys for table " & xlrngTarget.Name
        Sort_Rows = True
        Stop
        End If
    End With
End Function ' Sort_Rows.
</result></result></null></null></null></null></null></null>
 
Upvote 0
Re: Pivot Table - DrillDown - possibly one for VBA gurus

If your worksheets are established exactly as you say (exactly means exactly, such as the "DrillDown" sheet tab being spelled that way you said, and not "Drill Down" with a space), then place this in your workbook module and see if it accomplishes what you are after.

Good day all,

Firstly, thank you Tom Urtis and wesimmo for their contribution. I have further tried to gain assistance in another great code of Tom's, https://www.mrexcel.com/forum/excel-questions/289427-pivot-tables-showdetail-drill-down.html, for anyone else who may need that in the future!

I am working in Excel 2016, and as anastasia, I would like to be able to drill down source data from my pivot table to one dedicated worksheet (DrillDown). However, when I double click again somewhere else on my pivot table, I do not want the new data added below any previous datasets. Rather, I would like each new drill down to clear any data in my DrillDown worksheet, and then add the new dataset, and take the user to from the pivot sheet, to the DrillDown sheet.

Pivot table sheet: Movement Of Stock
Drill Down Sheet: DrillDown
Pivot table name: PivotTable1
Pivot source sheet: DATA

I would appreciate any assistance with this, I'm sure it's a small edit of Tom's code?

Cheers,
Gray
 
Last edited by a moderator:
Upvote 0

Forum statistics

Threads
1,223,248
Messages
6,171,021
Members
452,374
Latest member
keccles

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top