jaffey
01-30-2020, 12:40 PM
Hello all,
I am looking for assistance in modifying a piece of code I found in another thread on this site. The code runs via the Worksheet_BeforeDoubleClick event and is designed to be used in conjunction with a pivot table's drill down function, overriding it essentially. However, it only works properly if the underlying data in the target column consists of 1's and/or 0's. It then delete any rows that don't have a "1" in the target column. This is fine if know you are double clicking on a column that contains 1's and 0's, however, if there is anything else in the column, you end up staring at a blank page drill down page. So I would like to modify it such that it checks to see if the data in the target column does consist of 1's and/or 0's before executing. If not, just exit the sub.
The original thread does provide a partial workaround for this problem by allowing you to specify the column headers in the macro, however, this is not ideal as I have over fifty columns of 1's and 0's and new ones get added all the time
This is the code I would like to make check the target column for 1's and 0's before it runs:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim PTCll As PivotCell
On Error Resume Next
Set PTCll = Target.PivotCell
On Error GoTo 0
If Not PTCll Is Nothing Then
If PTCll.PivotCellType = xlPivotCellValue Then
Cancel = True
Target.ShowDetail = True
With ActiveSheet
FieldNo = Application.Match(PTCll.DataField.SourceName, .Rows(1), 0)
If Not IsError(FieldNo) Then
With .ListObjects(1)
.Range.AutoFilter Field:=FieldNo, Criteria1:="<>1" ', Operator:=xlAnd
.DataBodyRange.EntireRow.Delete
.Range.AutoFilter Field:=FieldNo
End With
.Range("A1").Select
End If
End With
End If
End If
End Sub
and this is the version that specifies the column headers:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim PTCll As PivotCell
On Error Resume Next
Set PTCll = Target.PivotCell
On Error GoTo 0
If Not PTCll Is Nothing Then
If PTCll.PivotCellType = xlPivotCellValue Then
Cancel = True
Target.ShowDetail = True
If Not IsError(Application.Match(PTCll.DataField.SourceName, Array("Metric1", "Metric2", "Metric4", "Metric5", "Metric6", "Metric7"), 0)) Then
With ActiveSheet
FieldNo = Application.Match(PTCll.DataField.SourceName, .Rows(1), 0)
If Not IsError(FieldNo) Then
With .ListObjects(1)
.Range.AutoFilter Field:=FieldNo, Criteria1:="<>1"
.DataBodyRange.EntireRow.Delete
.Range.AutoFilter Field:=FieldNo
End With
.Range("A1").Select
End If
End With
End If
End If
End If
End Sub
EDIT: I tried to add link to original post but I can't get the editor to accept it. If you search on "PivotTable.DrillDown and filtering the output" it should come up.
I am looking for assistance in modifying a piece of code I found in another thread on this site. The code runs via the Worksheet_BeforeDoubleClick event and is designed to be used in conjunction with a pivot table's drill down function, overriding it essentially. However, it only works properly if the underlying data in the target column consists of 1's and/or 0's. It then delete any rows that don't have a "1" in the target column. This is fine if know you are double clicking on a column that contains 1's and 0's, however, if there is anything else in the column, you end up staring at a blank page drill down page. So I would like to modify it such that it checks to see if the data in the target column does consist of 1's and/or 0's before executing. If not, just exit the sub.
The original thread does provide a partial workaround for this problem by allowing you to specify the column headers in the macro, however, this is not ideal as I have over fifty columns of 1's and 0's and new ones get added all the time
This is the code I would like to make check the target column for 1's and 0's before it runs:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim PTCll As PivotCell
On Error Resume Next
Set PTCll = Target.PivotCell
On Error GoTo 0
If Not PTCll Is Nothing Then
If PTCll.PivotCellType = xlPivotCellValue Then
Cancel = True
Target.ShowDetail = True
With ActiveSheet
FieldNo = Application.Match(PTCll.DataField.SourceName, .Rows(1), 0)
If Not IsError(FieldNo) Then
With .ListObjects(1)
.Range.AutoFilter Field:=FieldNo, Criteria1:="<>1" ', Operator:=xlAnd
.DataBodyRange.EntireRow.Delete
.Range.AutoFilter Field:=FieldNo
End With
.Range("A1").Select
End If
End With
End If
End If
End Sub
and this is the version that specifies the column headers:
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
Dim PTCll As PivotCell
On Error Resume Next
Set PTCll = Target.PivotCell
On Error GoTo 0
If Not PTCll Is Nothing Then
If PTCll.PivotCellType = xlPivotCellValue Then
Cancel = True
Target.ShowDetail = True
If Not IsError(Application.Match(PTCll.DataField.SourceName, Array("Metric1", "Metric2", "Metric4", "Metric5", "Metric6", "Metric7"), 0)) Then
With ActiveSheet
FieldNo = Application.Match(PTCll.DataField.SourceName, .Rows(1), 0)
If Not IsError(FieldNo) Then
With .ListObjects(1)
.Range.AutoFilter Field:=FieldNo, Criteria1:="<>1"
.DataBodyRange.EntireRow.Delete
.Range.AutoFilter Field:=FieldNo
End With
.Range("A1").Select
End If
End With
End If
End If
End If
End Sub
EDIT: I tried to add link to original post but I can't get the editor to accept it. If you search on "PivotTable.DrillDown and filtering the output" it should come up.