Excel: Show Ancestors

Some programs like MS Project show the hierarchy structure when filtering (i.e. they "show ancestors"). Excel does not do this - it understands indents and grouping (outlining), but it filters things out based on the cell, and doesn't show the hierarchy from lines above.

Attached is a macro that is aware of the Excel Outlining (grouping). Note: You can create the groupings automatically from the indents or the spaces using the Indent Macros.

It needs to be added to the Sheet that you wish to have the AutoFilter on as it relies on Events.

A common example is you paste from MS Project to Excel, then filter the Resources. If you use this spreadsheet, you can show the hierarchy of the relevant tasks.

Private Sub Worksheet_Change(ByVal Target As range)

Dim KeyCells As range

Dim KeyColumn As Integer

Dim Criteria As String

' The variable KeyCells contains the cells that will

' cause an alert when they are changed.

' Assumes the row above the autofilter contains the criteria

Set KeyCells = AutoFilter.range.Offset(-1).Rows(1)

If Not Application.Intersect(KeyCells, range(Target.address)) Is Nothing Then

Debug.Print "-------------------------"

Debug.Print "Cell " & Target.address & " has changed."

' Work out which column number it is

Debug.Print "Column " & Target.Column & " has changed"

'Debug.Print "Autofilter first column:" & AutoFilter.range.Column

KeyColumn = Target.Column - AutoFilter.range.Column + 1

On Error GoTo finish

If Target.Value = "" Then

AutoFilter.range.AutoFilter field:=KeyColumn ' Clear the filter

Else

AutoFilter.range.AutoFilter field:=KeyColumn, Criteria1:="=*" & Target.Value & "*", Operator:=xlAnd

Call showAncestors(Target.Offset(1), Target.Value)

End If

finish:

End Sub

Sub showAncestors(Optional start As range, Optional Criteria As String = "yes")

' Shows the ancestors based on a criteria

Dim rng As range

Debug.Print "-------------------------"

Set rng = start.Resize(AutoFilter.range.Rows.Count) ' Grow column to end

Debug.Print "range: " & rng.address

For i = 2 To rng.Rows.Count ' Go down rows, skipping header

' If rng(i) <> Criteria Then ' It doesn't match the criteria

' rng(i).EntireRow.Hidden = True ' Filter it out

' End If

If InStr(1, rng(i), Criteria) Then ' It matches the criteria

Debug.Print rng(i).address

indent = rng(i).EntireRow.OutlineLevel ' Save the level

For j = i - 1 To 2 Step -1 ' Check rows above to see if its less

If rng(j).EntireRow.OutlineLevel < indent Then

indent = rng(j).EntireRow.OutlineLevel ' Save this level

rng(j).EntireRow.Hidden = False ' Unhide this row as it's an ancestor

End If