Option Explicit
Public Const glbMainWSName As String = "ALL"
Public Const glbMainTable As String = "Table_Main"
Public Const glbColumnFindFirst As String = "END DEVICE"
Public Const glbColumnFindLast As String = "NOTES"
Public Const glbEffectRow As Integer = 6
Public Const glbColumnWidth = 4.86
Public glbMainWS As Worksheet
Public glbStartTime As Double
Public glbLastCol As Range
Public glbFirstCol As Range
Sub Click_Filter(ByVal Target As Range, Cancel As Boolean)
'Remember time when macro starts
glbStartTime = Timer
Call Update_Disable
If Target.Row = glbEffectRow Then 'user is filtering on effects and not causes
Call Filter_Remove
Call Effect_FindCol 'find effect columns
glbMainWS.Range(glbFirstCol, glbLastCol).EntireColumn.ColumnWidth = 0 'Hide All Effect Columns
Target.EntireColumn.ColumnWidth = glbColumnWidth
ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=Target.Column, Criteria1:="<>"
ActiveWindow.ScrollColumn = 1 'scroll to the left after filtering
Else 'user is filtering on causes
If Target.Column = 3 Then 'Plant Area Column
ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=3, Criteria1:=Target.Value
Call Effect_Locate 'only show columns that have marked effects
End If
If Target.Column = 5 Then ' Tag Column
ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=5, Criteria1:=Target.Value
Call Effect_Locate 'only show columns that have marked effects
End If
If Target.Column = 6 Then ' Equipment Column
ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=6, Criteria1:=Target.Value
Call Effect_Locate 'only show columns that have marked effects
End If
If Target.Column = 7 Then 'Device Column
ActiveSheet.ListObjects(glbMainTable).Range.AutoFilter Field:=7, Criteria1:=Target.Value
Call Effect_Locate 'only show columns that have marked effects
End If
End If
ActiveWindow.ScrollRow = 8 'scroll to top of list after filtering
Call Update_Enable
Debug.Print Round(Timer - glbStartTime, 2)
End Sub
Sub Effect_Locate()
Dim rng, Effect As Range
Dim arr(0 To 4000) As Double
Dim i, j As Integer
Dim SecondsElapsed As Double
Dim firstAddress As String
Dim oDict As Object
Dim key As Variant
Set glbMainWS = Worksheets(glbMainWSName)
Call Effect_FindCol 'find effect columns
'iterate through effects columns
i = 0
For Each rng In glbMainWS.ListObjects(glbMainTable).ListColumns(7).DataBodyRange.SpecialCells(xlCellTypeVisible)
Set rng = Range(glbMainWS.Cells(rng.Row, glbFirstCol.Column), glbMainWS.Cells(rng.Row, glbLastCol.Column))
Set Effect = rng.Find(What:="*", _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Effect Is Nothing Then 'at least one effect found
firstAddress = Effect.Address
Do
arr(i) = Effect.Column
i = i + 1
Set Effect = rng.FindNext(Effect)
Loop While Not Effect Is Nothing And Effect.Address <> firstAddress
End If
Next rng
'Hide All Effect Columns
glbMainWS.Range(glbFirstCol, glbLastCol).EntireColumn.ColumnWidth = 0 'using hidden = True/False seems to be slower than adjusting column width
'Remove Duplicates from array
Set oDict = CreateObject("Scripting.Dictionary")
For j = 0 To i - 1
oDict(arr(j)) = True
Next
'Show Effect Columns That Were Identified to Have Marks
Set rng = Nothing
Debug.Print Round(Timer - glbStartTime, 2)
For Each key In oDict.keys
If rng Is Nothing Then
Set rng = Cells(1, key)
Else
Set rng = Union(rng, Cells(1, key))
End If
Next key
Debug.Print Round(Timer - glbStartTime, 2)
rng.EntireColumn.ColumnWidth = glbColumnWidth 'this seems to be orders of magnitude slower than any other portion of the macro
Set rng = Nothing
End Sub
Sub Effect_FindCol()
Dim rng As Range
Set glbMainWS = Worksheets(glbMainWSName)
'Find first column of Effects
With glbMainWS.Rows("6:6")
Set rng = .Find(What:=glbColumnFindFirst, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlNext, _
MatchCase:=False)
End With
Set glbFirstCol = rng.Offset(0, 1)
'Find last column of Effects
With glbMainWS.Rows("8:8")
Set rng = .Find(What:=glbColumnFindLast, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByColumns, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
End With
Set glbLastCol = rng.Offset(0, -1)
End Sub
Sub Filter_Remove()
Dim rownum As Integer
Call Update_Disable
rownum = ActiveCell.Row 'get row number so that when the filters are cleared the last cell the user interacted with is scrolled to rather than the top of the worksheet
Worksheets(glbMainWSName).ListObjects(glbMainTable).AutoFilter.ShowAllData 'clear row filter
If glbFirstCol Is Nothing Or glbLastCol Is Nothing Then 'check that effect columns have been located
Call Effect_FindCol
End If
Range(Cells(1, glbFirstCol.Column), Cells(1, glbLastCol.Column)).EntireColumn.ColumnWidth = 4.86 'show all effect columns
ActiveWindow.ScrollRow = rownum
Call Update_Enable
End Sub
Sub Update_Disable()
With Application
.ScreenUpdating = False
.DisplayStatusBar = False
.DisplayAlerts = False
.EnableEvents = False
.EnableAnimations = False
.Calculation = xlCalculationManual
End With
Worksheets(glbMainWSName).DisplayPageBreaks = False
End Sub
Sub Update_Enable()
With Application
.ScreenUpdating = True
.DisplayStatusBar = True
.DisplayAlerts = True
.EnableEvents = True
.EnableAnimations = True
.Calculation = xlCalculationAutomatic
End With
End Sub