'********************************* Important *****************************************
'*     Copy and paste the code below into the worksheet code for the worksheets      *
'*     you want the right click menu items adding to.                                *		
'*                                                                                   * 
'*     Remove these lines before importing the module "RightClickProcess"            *
'*************************************************************************************       
'****** start of worksheet code 
Private Sub Worksheet_BeforeRightClick(ByVal Target As Range, Cancel As Boolean)
Call RightClick(Target.Row, Target.Column)
End Sub
Private Sub Worksheet_Deactivate()
Call RightClickOff
End Sub

'******* remove all the code above here before importing the "RightClickProcess" code *

Attribute VB_Name = "RightClickProcess"
'               All the code in this module is copyright of Abbydale Systems LLC.

'               The code is freeuse but please maintain this copyright information

Public cmdBtn1 As CommandBarButton          ' The command button for ShowOnly
Public cmdBtn2 As CommandBarButton          ' The command button for HideAll
Public cmdBtn3 As CommandBarButton          ' The command button for Reset
Public cmdBtn4 As CommandBarButton          ' The command button for DeleteHidden
Public LastRow, LastColumn As Long
Public HeaderRow As Boolean                 ' Headers?
Public StartRow As Long                     ' Used for the start row
Public Sub RightClick(MyRow As Long, MyCol As Long)

'         This routine will add the ShowOnly, HideAll and Reset buttons to the right click menu

'         The routine should be called with 2 required parameters. These are Row and Column of
'         the ActiveCell. This is used to determine the area where the options are allowed.

LastColumn = Cells(MyCol, Columns.Count).End(xlToLeft).Column
LastRow = Cells(Rows.Count, MyCol).End(xlUp).Row
If LastRow = 1 Then Exit Sub
StartRow = 1
HeaderRow = Check4Header(MyRow)
If HeaderRow = True Then StartRow = 2
With Application
On Error Resume Next
.CommandBars("Cell").Controls("ShowOnly").Delete
On Error Resume Next
.CommandBars("Cell").Controls("HideAll").Delete
On Error Resume Next
.CommandBars("Cell").Controls("Reset").Delete
On Error Resume Next
.CommandBars("Cell").Controls("DeleteHidden").Delete
On Error Resume Next
.CommandBars("Cell").Reset
End With
If MyCol > LastColumn Or MyRow > LastRow Then Exit Sub
On Error Resume Next
    With Application
        .CommandBars("Cell").Controls("ShowOnly").Delete
        Set cmdBtn1 = .CommandBars("Cell").Controls.Add(Temporary:=True)
        .CommandBars("Cell").Controls("HideAll").Delete
        Set cmdBtn2 = .CommandBars("Cell").Controls.Add(Temporary:=True)
        .CommandBars("Cell").Controls("Reset").Delete
        Set cmdBtn3 = .CommandBars("Cell").Controls.Add(Temporary:=True)
        .CommandBars("Cell").Controls("DeleteHidden").Delete
        Set cmdBtn4 = .CommandBars("Cell").Controls.Add(Temporary:=True)
    End With
    With cmdBtn1
        .Caption = "Show Only"
        .Style = msoButtonCaption
        .OnAction = "ShowOnly"          ' This is the procedure name for hiding cells without the cell value
    End With
    With cmdBtn2
        .Caption = "Hide All"
        .Style = msoButtonCaption
        .OnAction = "HideAll"           ' This is the procedure name for hiding all occurances of thw cell values
    End With
    With cmdBtn3
        .Caption = "Reset/Show All"
        .Style = msoButtonCaption
        .OnAction = "ShowAll"           ' This is the procedure for unhiding all the rows
    End With
    With cmdBtn4
        .Caption = "Delete Hidden"
        .Style = msoButtonCaption
        .OnAction = "DeleteHidden"      ' This is the procedure for deleting all hidden rows
    End With
On Error GoTo 0
End Sub
Public Sub RightClickOff()

'         This removes the right click menu items
    
    On Error Resume Next
        With Application
            .CommandBars("Cell").Controls("ShowOnly").Delete
            .CommandBars("Cell").Controls("HideAll").Delete
            .CommandBars("Cell").Controls("ShowAll").Delete
            .CommandBars("Cell").Controls("DeleteHidden").Delete
        End With
    On Error GoTo 0
End Sub
Public Sub ShowOnly()

'         This routine reads the value contained in the activeCell and then hides all rows that
'         do NOT contain that value in the same column
            
Rows.EntireRow.Hidden = False
MyMatch = ActiveCell.Value
LastColumn = Cells(ActiveCell.Column, Columns.Count).End(xlToLeft).Column
LastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
If LastRow = 1 Then Exit Sub
HeaderRow = True
For x = StartRow To LastRow
    If Cells(x, ActiveCell.Column).MergeCells = False Then
        If UCase(Cells(x, ActiveCell.Column).Value) <> UCase(MyMatch) Then
            Cells(x, ActiveCell.Column).EntireRow.Hidden = True
        Else
            Cells(x, ActiveCell.Column).EntireRow.Hidden = False
        End If
    Else
        If Cells(x, ActiveCell.Column).Value = "" Then
            If x > 1 Then
                If Cells(x - 1, ActiveCell.Column).EntireRow.Hidden = True Then
                    Cells(x, ActiveCell.Column).EntireRow.Hidden = True
                Else
                    Cells(x, ActiveCell.Column).EntireRow.Hidden = False
                End If
            Else
               MsgBox "Showall : Logic error"
               Exit Sub
            End If
         Else
            If UCase(Cells(x, ActiveCell.Column).Value) <> UCase(MyMatch) Then
                Cells(x, ActiveCell.Column).EntireRow.Hidden = True
            Else
                Cells(x, ActiveCell.Column).EntireRow.Hidden = False
            End If
        End If
    End If
Next
End Sub
Public Sub ShowAll()

'         This routine resets (unhides) all rows of the worksheet

Rows.EntireRow.Hidden = False
End Sub
Public Sub HideAll()

'         This routine reads the value contained in the activeCell and then hides all rows that
'         contain that value in the same column

Rows.EntireRow.Hidden = False
MyMatch = ActiveCell.Value
LastColumn = Cells(ActiveCell.Column, Columns.Count).End(xlToLeft).Column
LastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
For x = StartRow To LastRow
    If Cells(x, ActiveCell.Column).MergeCells = False Then
        If UCase(Cells(x, ActiveCell.Column).Value) = UCase(MyMatch) Then
            Cells(x, ActiveCell.Column).EntireRow.Hidden = True
        Else
            Cells(x, ActiveCell.Column).EntireRow.Hidden = False
        End If
    Else
        If Cells(x, ActiveCell.Column).Value = "" Then
            If x > 1 Then
                If Cells(x - 1, ActiveCell.Column).EntireRow.Hidden = True Then
                    Cells(x, ActiveCell.Column).EntireRow.Hidden = True
                Else
                    Cells(x, ActiveCell.Column).EntireRow.Hidden = False
                End If
            Else
               MsgBox "HideAll : Logic error"
               Exit Sub
            End If
         Else
            If UCase(Cells(x, ActiveCell.Column).Value) = UCase(MyMatch) Then
                Cells(x, ActiveCell.Column).EntireRow.Hidden = True
            Else
                Cells(x, ActiveCell.Column).EntireRow.Hidden = False
            End If
        End If
    End If
Next
End Sub
Public Sub DeleteHidden()

'         This subroutine will delete all the hidden rows

Dim Ans As Variant
Ans = MsgBox("Are you sure you want to delete all the hidden rows?", vbYesNo, "Confirm Delete of Hidden Rows")
If Ans = vbYes Then
    LastRow = Cells(Rows.Count, ActiveCell.Column).End(xlUp).Row
    For x = LastRow To 1 Step -1
        If Rows(x).Hidden = True Then Rows(x).EntireRow.Delete
    Next
End If
End Sub
Public Function Check4Header(MyRow) As Boolean

'         This function will attempt to determone if the worksheet has headers or not. It will
'         determine this by checking:

'         If a row 2 column is numeric and the same column in row 1 isn't
'         If a row 2 column contains a date and the same row 2 column doesn't
'         If the text in row 1 is bold.

Check4Header = False
If MyRow = 1 Then Exit Function
MyCols = Cells(1, Columns.Count).End(xlToLeft).Column
For y = 1 To MyCols
    If IsNumeric(Cells(2, y).Value) Then
        If Not IsNumeric(Cells(1, y)) Then
            Check4Header = True
            Exit Function
        End If
    End If
    If IsDate(Cells(2, y).Value) Then
        If Not IsDate(Cells(1, y)) Then
            Check4Header = True
            Exit Function
        End If
    End If
    If Cells(1, y).Font.Bold Then
        Check4Header = True
        Exit Function
    End If
Next
End Function