VBA SOURCE

CODE BOOK

Learn How To Create This

AMAZING Excel ONE CLICK
Dynamic Filter Workbook

DOWNLOAD VIEW
APPLICATION TRAINING
by: Randy Austin
 ABOUT THE AUTHOR
A two-time Microsoft MVP & lifetime Excel enthusiast, Randy
Austin founded Excel For Freelancers in 2017. Excel For
Freelancers quickly became the most prominent resource Excel
for developers to learn how to turn their passion for Excel into
profits by building & selling their own excel-based applications
for passive & recurring income.

With nearly 300,000 YouTube subscribers, 14,000,000 video

views, 200+ comprehensive training videos, and a thriving 40,000
member Facebook community, Excel For Freelancers has
positioned itself as the #1 Excel developers resource in the world.

Get free content, training, and downloads just by clicking any of the free
resources below:

WEBSITE YOUTUBE FACEBOOK TWITTER

INSTAGRAM TELEGRAM RUMBLE

OUR COURSES &
PRODUCTS
This comprehensive program will take you through
a 12-phase process that will turn your enthusiasm
for Excel into passive income.
Click here to learn more

16 hour masterclass that will teach you the tips,

tricks and techniques on how to create a dynamic
single-click dashboard, and a ton more
Click here to learn more

Incredible Package of 175 of my BEST Applications

into a SINGLE ZIP File which also includes the "175
Workbook Library".

Click here to learn more

With 1000 live links, continuously updating content,

sort-able and filterable items, you will always have
exactly what you need, when you need it.

Click here to learn more

 Table of Contents
Projects ..............................................................................................................................................................................................2
VBAProject .....................................................................................................................................................................................2
Documents ..................................................................................................................................................................................2
Sheet1......................................................................................................................................................................................2
Worksheet_Activate [Sub ]....................................................................................................................................................2
Worksheet_Change [Sub ] ....................................................................................................................................................2
Worksheet_Deactivate [Sub ] ...............................................................................................................................................2
Worksheet_SelectionChange [Sub ] .....................................................................................................................................2
Sheet2......................................................................................................................................................................................4
(Declarations)........................................................................................................................................................................4
ThisWorkbook ..........................................................................................................................................................................6
(Declarations)........................................................................................................................................................................6
Workbook_Activate [Sub ].....................................................................................................................................................6
Workbook_Deactivate [Sub ] ................................................................................................................................................6
Modules .......................................................................................................................................................................................8
CodeReset_Macs .....................................................................................................................................................................8
(Declarations)........................................................................................................................................................................8
ResetCalc [Sub ] ...................................................................................................................................................................8
StopCalc [Sub ] .....................................................................................................................................................................8
FilterMacros ...........................................................................................................................................................................10
(Declarations)......................................................................................................................................................................10
ClearFilters [Sub ] ...............................................................................................................................................................10
DeleteFilters [Sub ] .............................................................................................................................................................10
HideFilters [Sub ] ................................................................................................................................................................10
LoadFilters [Sub ] ................................................................................................................................................................10
RunFilter [Sub ] ...................................................................................................................................................................11
ShowFilters [Sub ] ...............................................................................................................................................................13
ItemMacros ............................................................................................................................................................................15
(Declarations)......................................................................................................................................................................15
CancelNewItem [Sub ] ........................................................................................................................................................15
DeleteItem [Sub ] ................................................................................................................................................................15
ItemSavedMess [Sub ] ........................................................................................................................................................15
LoadItem [Sub ]...................................................................................................................................................................15
NewItem [Sub ] ...................................................................................................................................................................15
RefreshItemTable [Sub ] .....................................................................................................................................................16
SaveUpdateItem [Sub ] .......................................................................................................................................................16
TabMacros .............................................................................................................................................................................18
do_nothing [Sub ] ................................................................................................................................................................18
GetColLtr [Function ] ...........................................................................................................................................................18
GetTabOrder [Function ] .....................................................................................................................................................18
SetOnkey [Sub ] ..................................................................................................................................................................18
TabRange [Sub ] .................................................................................................................................................................18
UpOrDownArrow [Sub ] .......................................................................................................................................................19

1 of 21
T
Sheet1 Advanced_Filters.xlsm

1 Private Sub Worksheet_Activate()

2 SetOnkey (True)
3 End Sub
4
5
6 Private Sub Worksheet_Change(ByVal Target As Range)
7 If [Link] > 1 Then Exit Sub
8 If Not Intersect(Target, Range("D6:E999" )) Is Nothing And Range("A9" ).Value = False Then

9 Range("A7" ).Value = [Link]

10 RunFilter
11 End If
12 End Sub
13
14 Private Sub Worksheet_Deactivate()
15 SetOnkey (False)
16 End Sub
17
18 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
19 If [Link] > 1 Then Exit Sub
20 If Not Intersect(Target, Range("D6:D999" )) Is Nothing And Range("A9" ).Value = False Then

21 Range("A7" ).Value = [Link]

22 Range("A9" ).Value = True
23 If [Link] = "¨" Then
24 [Link] = "þ"
25 RunFilter
26 Range("A9" ).Value = False
27 End
28 End If
29 If [Link] = "þ" Then
30 [Link] = "¨"
31 RunFilter
32 End If
33 Range("A9" ).Value = False
34 End If
35 If Not Intersect(Target, Range("G13:M999" )) Is Nothing And Range("G" & [Link]).Value
<> Empty Then
36 Range("B1" ).Value = [Link]
37 LoadItem
38 End If
39 End Sub
40

2 of 21
 Index

C
Cells, 2
CountLarge, 2

E
Empty, 2

I
Intersect, 2

L
LoadItem, 2

R
Range, 2
Row, 2
RunFilter, 2

S
SetOnkey, 2

T
Target, 2

V
Value, 2

W
Worksheet_Activate, 2
Worksheet_Change, 2
Worksheet_Deactivate, 2
Worksheet_SelectionChange, 2

3 of 21
 Sheet2 Advanced_Filters.xlsm

1 Option Explicit
2

4 of 21
 Index

E
Explicit, 4

5 of 21
T
ThisWorkbook Advanced_Filters.xlsm

1 Option Explicit
2
3 Private Sub Workbook_Activate()
4 If [Link] = "Items" Then SetOnkey (True)
5 End Sub
6
7 Private Sub Workbook_Deactivate()
8 SetOnkey (False)
9 End Sub
10
11

6 of 21
 Index

A
ActiveSheet, 6

E
Explicit, 6

N
Name, 6

S
SetOnkey, 6

W
Workbook_Activate, 6
Workbook_Deactivate, 6

7 of 21
T
CodeReset_Macs Advanced_Filters.xlsm

1 Option Explicit
2 Sub ResetCalc()
3 With Application
4 .Calculation = xlCalculationAutomatic
5 .ScreenUpdating = True
6 End With
7 End Sub
8
9
10
11
12 Sub StopCalc()
13 With Application
14 .Calculation = xlCalculationManual
15 .ScreenUpdating = False
16 End With
17 End Sub

8 of 21
 Index

A
Application, 8

C
Calculation, 8

E
Explicit, 8

R
ResetCalc, 8

S
ScreenUpdating, 8
StopCalc, 8

X
xlCalculationAutomatic, 8
xlCalculationManual, 8

9 of 21
T
FilterMacros Advanced_Filters.xlsm

1 Option Explicit
2 '''Code provided by Randy Austin, Founder of Excel For Freelancers
3 ''More Free Training at: [Link]
4 Sub ClearFilters()
5 [Link]("AA4:DG9999" ).ClearContents 'Clear Old Results
6 LoadFilters
7 RefreshItemTable
8 End Sub
9
10
11
12 Sub DeleteFilters()
13 On Error Resume Next
14 [Link]("Criteria" ).Delete
15 [Link]("Extract" ).Delete
16 On Error GoTo 0
17 End Sub
18
19 Sub HideFilters()
20 With Sheet1
21 .Shapes("ClearFilterBtn" ).Visible = msoFalse
22 .Shapes("CloseFilterBtn" ).Visible = msoFalse
23 .Shapes("OpenFilterBtn" ).Visible = msoCTrue
24 .Range("D:E" ).[Link] = True
25 End With
26 End Sub
27 Sub LoadFilters()
28 Dim FiltRow, DataCol, LastItemFiltRow, LastItemRow, UniqueListItems As Long
29 Dim FiltType As String
30 StopCalc
31 [Link]("AA4:AJ999" ).ClearContents 'Clear any old results
32 With Sheet1
33 .Range("A9" ).Value = True 'Set Filter Load To True
34 LastItemFiltRow = .Range("D999" ).End(xlUp).Row
35
36 'Clear existing Filter Range
37 .Range("ClearRange" ).Copy
38 .Range("D6:E" & LastItemFiltRow).PasteSpecial xlPasteAll 'Clear Filter Area
39 .Range("B6:B999" ).ClearContents
40 FiltRow = 6 'Start Filter Row at 6
41
42 For DataCol = 1 To 7 'Expand for larger data tables
43 FiltType = [Link](2, DataCol).Value
44
45 'On Text Type
46 If FiltType = "Text" Then
47 .Range("TextSearch" ).Copy
48 .Range("D" & FiltRow).PasteSpecial xlPasteAll
49 .Range("E" & FiltRow).Value = "Enter " & [Link](3, DataCol).Value & ":"
50 .Range("B" & FiltRow).Value = DataCol + 26
51 FiltRow = FiltRow + 2
52 GoTo NextCol
53 End If
54
55 'On List Type Item
56 If FiltType = "List" Then
57 DeleteFilters 'Clear Old Criteria & Extract Named Ranges
58 .Range("E" & FiltRow - 1).Value = [Link](3, DataCol).Value 'Header Name
59 LastItemRow = [Link](99999, DataCol).End(xlUp).Row 'Last List Type Item in
Column
60
1 2 3 4

10 of 21
T
FilterMacros Advanced_Filters.xlsm
1 2 3 4
61 [Link]("K3:K9999" ).ClearContents
62 Range([Link](3, DataCol), [Link](LastItemRow, DataCol)).
AdvancedFilter xlFilterCopy, CopyToRange:=[Link]("K3" ), unique:=True
63 UniqueListItems = [Link]("K999999" ).End(xlUp).Row - 3
64 If UniqueListItems < 1 Then GoTo SkipItems
65 .Range("ListSearch" ).Copy
66 .Range("D" & FiltRow).PasteSpecial xlPasteAll
67 .Range("D" & FiltRow & ":E" & FiltRow).Copy
68 .Range("D" & FiltRow + 1 & ":E" & FiltRow + UniqueListItems - 1).PasteSpecial
xlPasteAll
69 .Range("E" & FiltRow & ":E" & FiltRow + UniqueListItems - 1).Value = Sheet2.
Range("K4:K" & UniqueListItems + 3).Value
70 .Range("B" & FiltRow & ":B" & FiltRow + UniqueListItems - 1).Value = Sheet2.
Cells(3, DataCol).Value
71 [Link]("K3:K9999" ).ClearContents
72 FiltRow = FiltRow + UniqueListItems + 1
73 SkipItems:
74 GoTo NextCol
75 End If
76
77 'On Date Type
78 If FiltType = "Date" Then
79 .Range("E" & FiltRow - 1).Value = [Link](3, DataCol).Value
80 .Range("DateSearch" ).Copy
81 .Range("D" & FiltRow).PasteSpecial xlPasteAll
82 Range("B" & FiltRow).Value = DataCol + 26 'From Date
83 Range("B" & FiltRow + 1).Value = DataCol + 26 + 3 'To Date
84 FiltRow = FiltRow + 3
85 GoTo NextCol
86 End If
87
88 'On Amount Type
89 If FiltType = "Amount" Then
90 .Range("E" & FiltRow - 1).Value = [Link](3, DataCol).Value
91 .Range("AmountSearch" ).Copy
92 .Range("D" & FiltRow).PasteSpecial xlPasteAll
93 Range("B" & FiltRow).Value = DataCol + 26 'From Amount
94 Range("B" & FiltRow + 1).Value = DataCol + 26 + 3 'To Amount
95 FiltRow = FiltRow + 3
96 GoTo NextCol
97 End If
98
99 'On Number Type
100 If FiltType = "Number" Then
101 .Range("E" & FiltRow - 1).Value = [Link](3, DataCol).Value
102 .Range("NumberSearch" ).Copy
103 .Range("D" & FiltRow).PasteSpecial xlPasteAll
104 Range("B" & FiltRow).Value = DataCol + 26 'From Number
105 Range("B" & FiltRow + 1).Value = DataCol + 26 + 3 'To Number
106 FiltRow = FiltRow + 3
107 GoTo NextCol
108 End If
109
110 NextCol:
111 Next DataCol
112 .Range("A9" ).Value = False
113 End With
114 ResetCalc
115 End Sub
116
117 Sub RunFilter()
1

11 of 21
T
FilterMacros Advanced_Filters.xlsm
1
118 Dim ActRow, DataCol, FirstListRow, LastDataRow, LastListRow, ListItemRow, CriteriaRow,
CriteriaCol As Long
119 Dim LastCriteriaRow1, LastCriteriaRow2, LastResultsRow1, LastResultsRow2, LastResultsRow3
As Long
120 Dim FoundLast As Range
121 With Sheet1
122 .Range("A9" ).Value = True
123 .Range("G13:M9999" ).ClearContents 'Clear Existing Data
124 'Determine Field Type
125 ActRow = .Range("A7" ).Value 'Active Filter Change Row
126 DataCol = .Range("B" & ActRow).Value
127
128 'On Text Change
129 If .Range("D" & ActRow).Value = "L" Then
130 If InStr(.Range("E" & ActRow).Value, ":" ) <> 0 Or .Range("E" & ActRow).Value =
Empty Then [Link](4, DataCol).ClearContents Else: [Link](4, DataCol).
Value = "*" & .Range("E" & ActRow).Value & "*"
131 End If
132
133 'On Date, Amount Or Number From/Min
134 If .Range("D" & ActRow).Value = "From:" Or .Range("D" & ActRow).Value = "Min:" Then

135 [Link](4, DataCol).Value = ">=" & .Range("E" & ActRow).Value 'From/Min

Value
136 End If
137
138 'On Date, Amount Or Number To/Max
139 If .Range("D" & ActRow).Value = "To:" Or .Range("D" & ActRow).Value = "Max:" Then
140 [Link](4, DataCol).Value = "<=" & .Range("E" & ActRow).Value 'To/Max Value
141 End If
142
143 'Run Advanced Filter 1
144 DeleteFilters 'Clear Old Criteria & Extract Named Ranges
145 LastDataRow = [Link]("A9999" ).End(xlUp).Row 'Determin Last Row of Item Data
146 [Link]("BA4:BG9999" ).ClearContents 'Clear Any Previous Results
147 [Link]("A3:G" & LastDataRow).AdvancedFilter xlFilterCopy, CriteriaRange:=Sheet2.
Range("AA3:AJ4" ), CopyToRange:=[Link]("BA3:BG3" ), unique:=True
148 LastResultsRow1 = [Link]("BA9999" ).End(xlUp).Row
149 If LastResultsRow1 < 4 Then GoTo NoData
150
151 'On List Type Change
152 If .Range("D" & ActRow).Value = "¨" Or .Range("D" & ActRow).Value = "þ" Then
153 FirstListRow = .Range("D8:D" & ActRow).Find("" , SearchOrder:=xlByRows,
SearchDirection:=xlPrevious).Row + 1
154 LastListRow = .Range("D" & ActRow).End(xlDown).Row
155
156 'Set Criteria Row & Column
157 If .Range("B" & ActRow).Value = "Type" Then CriteriaCol = 77 Else: CriteriaCol =
103
158 Range([Link](4, CriteriaCol), [Link](999, CriteriaCol)).ClearContents
'Clear Existing Criteria
159 CriteriaRow = 4
160
161 For ListItemRow = FirstListRow To LastListRow
162 If .Range("D" & ListItemRow).Value = "þ" Then
163 [Link](CriteriaRow, CriteriaCol).Value = .Range("E" & ListItemRow).
Value 'Set Item Criteria
164 CriteriaRow = CriteriaRow + 1
165 End If
166 Next ListItemRow
167 End If
1 2

12 of 21
T
FilterMacros Advanced_Filters.xlsm
1 2
168 LastCriteriaRow1 = [Link]("BY999" ).End(xlUp).Row 'Last Criteria 1 Row
169 LastCriteriaRow2 = [Link]("CY999" ).End(xlUp).Row 'Last Criteria 2 Row
170
171 'Run Advanced Filter 2
172 DeleteFilters 'Clear Old Criteria & Extract Named Ranges
173 [Link]("BA3:BG" & LastResultsRow1).AdvancedFilter xlFilterCopy, CriteriaRange:=
[Link]("BY3:BY" & LastCriteriaRow1), CopyToRange:=[Link]("CA3:CG3" ),
unique:=True
174 LastResultsRow2 = [Link]("CA9999" ).End(xlUp).Row
175 If LastResultsRow2 < 4 Then GoTo NoData
176
177 'Run Advanced Filter 2
178 DeleteFilters 'Clear Old Criteria & Extract Named Ranges
179 [Link]("CA3:CG" & LastResultsRow2).AdvancedFilter xlFilterCopy, CriteriaRange:=
[Link]("CY3:CY" & LastCriteriaRow2), CopyToRange:=[Link]("DA3:DG3" ),
unique:=True
180 LastResultsRow3 = [Link]("DA9999" ).End(xlUp).Row
181 If LastResultsRow3 < 4 Then GoTo NoData
182
183 .Range("G13:M" & LastResultsRow3 + 9).Value = [Link]("DA4:DG" & LastResultsRow3
).Value 'Copy Over Filtered Data
184
185 NoData:
186
187 .Range("A9" ).Value = False 'Set Load To false to prevent duplicate runs
188 .Range("G13" ).Select 'Select First Item In Table to reload
189 End With
190
191 End Sub
192
193 Sub ShowFilters()
194 With Sheet1
195 .Shapes("ClearFilterBtn" ).Visible = msoCTrue
196 .Shapes("CloseFilterBtn" ).Visible = msoCTrue
197 .Shapes("OpenFilterBtn" ).Visible = msoFalse
198 .Range("D:E" ).[Link] = False
199 End With
200 End Sub

13 of 21
 Index

A S
ActRow, 12 SearchDirection, 12
AdvancedFilter, 11-13 SearchOrder, 12
Shapes, 10, 13
C Sheet1, 10, 12, 13
Cells, 10-12 Sheet2, 10-13
ClearContents, 10-12 ShowFilters, 13
ClearFilters, 10 SkipItems, 11
Copy, 10, 11 StopCalc, 10
CopyToRange, 11-13
CriteriaCol, 12 U
CriteriaRange, 12, 13 unique, 11-13
CriteriaRow, 12 UniqueListItems, 10, 11

D V
DataCol, 10-12 Value, 10-13
Delete, 10 Visible, 10, 13
DeleteFilters, 10, 12, 13
X
E xlByRows, 12
Empty, 12 xlDown, 12
EntireColumn, 10, 13 xlFilterCopy, 11-13
Explicit, 10 xlPasteAll, 10, 11
xlPrevious, 12
F xlUp, 10-13
FiltRow, 10, 11
FiltType, 10, 11
Find, 12
FirstListRow, 12
FoundLast, 12

H
Hidden, 10, 13
HideFilters, 10

I
InStr, 12

L
LastCriteriaRow1, 12, 13
LastCriteriaRow2, 12, 13
LastDataRow, 12
LastItemFiltRow, 10
LastItemRow, 10, 11
LastListRow, 12
LastResultsRow1, 12, 13
LastResultsRow2, 12, 13
LastResultsRow3, 12, 13
ListItemRow, 12
LoadFilters, 10

M
msoCTrue, 10, 13
msoFalse, 10, 13

N
Names, 10
NextCol, 10, 11
NoData, 12, 13

P
PasteSpecial, 10, 11

R
Range, 10-13
RefreshItemTable, 10
ResetCalc, 11
Row, 10-13
RunFilter, 11

14 of 21
T
ItemMacros Advanced_Filters.xlsm

1 Option Explicit
2 Dim ItemRow, ItemCol, ItemDbRow, LastRow As Long
3
4 Sub CancelNewItem()
5 [Link]("G13" ).Select
6 End Sub
7
8 Sub DeleteItem()
9 If MsgBox("Are you sure you want to delete this item?" , vbYesNo, "Delete Item" ) = vbNo
Then Exit Sub
10 With Sheet1
11 If .Range("B4" ).Value = Empty Then Exit Sub
12 StopCalc
13 ItemDbRow = .Range("B4" ).Value 'Itemact Database Row
14 [Link](ItemDbRow & ":" & ItemDbRow).Delete
15 .Range("G13" ).Select
16 End With
17 RefreshItemTable
18 ResetCalc
19 End Sub
20
21 Sub ItemSavedMess()
22 'You can duplicate this for any type of Fade Out Message. Simply rename the macro and
Shape Name and you are done
23 Dim CountNumb As Integer 'Integers used for whole numbers
24 Dim StartTime, Delay As Double 'Double Used for decimals
25 With [Link]("ItemSavedMesg" ) 'Note Sheet in which the shape is on must be
active. if not add '[Link]' before (or whichever sheet number you require)
26 .Visible = True 'Make Message Visible
27 For CountNumb = 1 To 100 'Create a loop (feel free to change the numbers for faster of
slower)
28 .[Link] = CountNumb / 100 'Set the transparency here
29 Delay = 0.002 'Set the delay . increase for a slower fade out
30 StartTime = Timer 'Start the timer
31 Do
32 DoEvents
33 Loop While Timer - StartTime < Delay 'Set loop while Timer - Start time is less
than the Delay to slow down loop
34 Next CountNumb
35 .Visible = False 'Hide message on completion of macro
36 End With
37 End Sub
38
39 Sub LoadItem()
40 With Sheet1
41 .Range("I6,I8,I10,L6,L8,L10" ).ClearContents
42 .Shapes("ExistItemGrp" ).Visible = msoCTrue
43 .Shapes("NewItemGrp" ).Visible = msoFalse
44 ItemRow = .Range("B1" ).Value
45 For ItemCol = 8 To 13
46 .Range(.Cells(3, ItemCol).Value).Value = .Cells(ItemRow, ItemCol).Value 'Add in
Itemact Details
47 Next ItemCol
48 .Range("B2" ).Value = .Range("G" & ItemRow).Value 'Add Itemact ID
49 .Range("B5" ).Value = False 'Set New Itemact To False
50 End With
51 End Sub
52
53 Sub NewItem()
54 With Sheet1
55 .Range("B1,B2,I6,I8,I10,L6,L8,L10" ).ClearContents
1 2

15 of 21
T
ItemMacros Advanced_Filters.xlsm
1 2
56 .Shapes("ExistItemGrp" ).Visible = msoFalse
57 .Shapes("NewItemGrp" ).Visible = msoCTrue
58 .Range("B5" ).Value = True 'Set new Itemact to True
59 .Range("I6" ).Select
60 End With
61 End Sub
62
63 Sub RefreshItemTable()
64 With Sheet1
65 .Range("G13:M9999" ).ClearContents
66 LastRow = [Link]("A99999" ).End(xlUp).Row
67 .Range("G13:M" & LastRow + 9).Value = [Link]("A4:G" & LastRow).Value 'Copy
Over Data
68 End With
69 End Sub
70
71 Sub SaveUpdateItem()
72 With Sheet1
73 If .Range("I6" ).Value = Empty Then
74 MsgBox "Please enter an Item Name"
75 Exit Sub
76 End If
77
78 If .Range("B5" ).Value = True Then 'New Itemact
79 ItemDbRow = [Link]("A99999" ).End(xlUp).Row + 1
80 [Link]("A" & ItemDbRow).Value = "CS-" & ItemDbRow - 3
81 Else: 'Existing Item
82 If .Range("B4" ).Value = Empty Then Exit Sub
83 ItemDbRow = .Range("B4" ).Value 'Itemact Database Row
84 End If
85
86 StopCalc
87 For ItemRow = 6 To 10 Step 2
88 For ItemCol = 9 To 12 Step 3
89 [Link](ItemDbRow, .Cells(ItemRow, ItemCol + 10).Value).Value = .Cells(
ItemRow, ItemCol).Value
90 Next ItemCol
91 Next ItemRow
92 .Range("B5" ).Value = False 'Set New Itemact To False
93 .Shapes("ExistItemGrp" ).Visible = msoCTrue
94 .Shapes("NewItemGrp" ).Visible = msoFalse
95 End With
96 RefreshItemTable
97 LoadFilters
98 ResetCalc
99 ItemSavedMess
100 End Sub

16 of 21
 Index

A
ActiveSheet, 15

C
CancelNewItem, 15
Cells, 15, 16
ClearContents, 15, 16
CountNumb, 15

D
Delay, 15
Delete, 15
DeleteItem, 15
DoEvents, 15

E
Empty, 15, 16
Explicit, 15

F
Fill, 15

I
ItemCol, 15, 16
ItemDbRow, 15, 16
ItemRow, 15, 16
ItemSavedMess, 15, 16

L
LastRow, 15, 16
LoadFilters, 16
LoadItem, 15

M
MsgBox, 15, 16
msoCTrue, 15, 16
msoFalse, 15, 16

N
NewItem, 15

R
Range, 15, 16
RefreshItemTable, 15, 16
ResetCalc, 15, 16
Row, 16

S
SaveUpdateItem, 16
Shapes, 15, 16
Sheet1, 15, 16
Sheet2, 15, 16
StartTime, 15
StopCalc, 15, 16

T
Timer, 15
Transparency, 15

V
Value, 15, 16
vbNo, 15
vbYesNo, 15
Visible, 15, 16

X
xlUp, 16

17 of 21
T
TabMacros Advanced_Filters.xlsm

1
2 Sub do_nothing()
3 'nothing to do
4 End Sub
5
6
7 Private Function GetColLtr(sAddr As String) As String
8 Dim iPos As Long, sTest As String
9 Do While iPos < 3
10 iPos = iPos + 1
11 If IsNumeric(Mid(sAddr, iPos, 1)) Then
12 Exit Do
13 Else
14 sTest = sTest & Mid(sAddr, iPos, 1)
15 End If
16 Loop
17 GetColLtr = sTest
18 End Function
19
20
21
22 Function GetTabOrder() As Variant
23 '--set the tab order of input cells - change ranges as required
24 ' don't include "$" in these cell references
25 If [Link] > 8 And [Link] < 12 Then
26 GetTabOrder = Array("I6" , "I8" , "I10" , "L6" , "L8" , "L10" )
27 Else: GetTabOrder = Array("" )
28 End If
29
30 ' If [Link] > 27 Then
31 End Function
32 Sub SetOnkey(ByVal state As Boolean)
33 'Compiled By Randy Austin
34 'Workbook Provided By [Link]
35 If state Then
36 With Application
37 .OnKey "{TAB}" , "'TabRange xlNext'"
38 .OnKey "~" , "'TabRange xlNext'"
39 .OnKey "{ENTER}" , "'TabRange xlNext'"
40 .OnKey "{RIGHT}" , "'TabRange xlNext'"
41 .OnKey "{LEFT}" , "'TabRange xlPrevious'"
42 .OnKey "+{TAB}" , "'TabRange xlPrevious'"
43 .OnKey "{DOWN}" , "'UpOrDownArrow xlDown'"
44 .OnKey "{UP}" , "'UpOrDownArrow xlUp'"
45 End With
46 Else
47 'reset keys
48 With Application
49 .OnKey "{ENTER}"
50 .OnKey "{TAB}"
51 .OnKey "~"
52 .OnKey "+{TAB}"
53 .OnKey "{RIGHT}"
54 .OnKey "{LEFT}"
55 .OnKey "{DOWN}"
56 .OnKey "{UP}"
57 End With
58 End If
59 End Sub
60
61 Sub TabRange(Optional iDirection As Integer = xlNext)
1

18 of 21
T
TabMacros Advanced_Filters.xlsm
1
62
63 Dim vTabOrder As Variant, m As Variant
64 Dim lItems As Long, iAdjust As Long
65 On Error GoTo ExitSub
66 '--get the tab order from shared function
67 vTabOrder = GetTabOrder
68 lItems = UBound(vTabOrder) - LBound(vTabOrder) + 1
69
70 On Error Resume Next
71 m = [Link]([Link](0, 0), vTabOrder, False)
72
73
74 '--if activecell is not in Tab Order return to the first cell
75 If IsError(m) Then
76 m = 1
77 Else
78 '--get adjustment to index
79 iAdjust = IIf(iDirection = xlPrevious, -1, 1)
80
81 '--calculate new index wrapping around list
82 m = (m + lItems + iAdjust - 1) Mod lItems + 1
83 End If
84
85 '--select cell adjusting for Option Base 0 or 1
86 [Link] = False
87 Range(vTabOrder(m + (LBound(vTabOrder) = 0))).Select
88
89 ExitSub:
90 [Link] = True
91 End Sub
92
93 Sub UpOrDownArrow(Optional iDirection As Integer = xlUp)
94
95 Dim vTabOrder As Variant
96 Dim lRowClosest As Long, lRowTest As Long
97 Dim i As Long, iSign As Integer
98
99 Dim sActiveCol As String
100 Dim bFound As Boolean
101
102 '--get the tab order from shared function
103 vTabOrder = GetTabOrder
104
105 '--find TabCells in same column as ActiveCell in iDirection
106 '-- rTest will include ActiveCell
107
108 sActiveCol = GetColLtr([Link](0, 0))
109
110 iSign = IIf(iDirection = xlDown, -1, 1)
111 lRowClosest = IIf(iDirection = xlDown, [Link] + 1, 0)
112
113 For i = LBound(vTabOrder) To UBound(vTabOrder)
114 If GetColLtr(CStr(vTabOrder(i))) = sActiveCol Then
115 lRowTest = Range(CStr(vTabOrder(i))).Row
116
117 '--find closest cell to ActiveCell in rTest
118 If iSign * lRowTest > iSign * lRowClosest And _
119 iSign * lRowTest < iSign * [Link] Then
120 '--at least one cell in iDirection of same columnn
121 bFound = True
122 lRowClosest = lRowTest
1 2 3 4

19 of 21
T
TabMacros Advanced_Filters.xlsm
1 2 3 4
123 End If
124 End If
125 Next i
126
127 If bFound Then
128 [Link] = False
129 Cells(lRowClosest, [Link]).Select
130 [Link] = True
131 End If
132 End Sub

20 of 21
 Index
UpOrDownArrow, 19
_
_, 19 V
vTabOrder, 19
A
ActiveCell, 18-20 X
Address, 19 xlDown, 19
Application, 18-20 xlNext, 18
Array, 18 xlPrevious, 19
xlUp, 19
B
bFound, 19, 20

C
Cells, 20
Column, 18, 20
Count, 19

D
do_nothing, 18

E
EnableEvents, 19, 20
ExitSub, 19

G
GetColLtr, 18, 19
GetTabOrder, 18, 19

I
i, 19, 20
iAdjust, 19
iDirection, 18, 19
IIf, 19
iPos, 18
IsError, 19
iSign, 19
IsNumeric, 18

L
LBound, 19
lItems, 19
lRowClosest, 19, 20
lRowTest, 19

M
m, 19
Match, 19
Mid, 18

O
OnKey, 18

R
Range, 19
Row, 18, 19
Rows, 19

S
sActiveCol, 19
sAddr, 18
SetOnkey, 18
state, 18
sTest, 18

T
TabRange, 18

U
UBound, 19

21 of 21
 Thank You!
This source code was created and made available
to help you gain a better understanding of how
VBA is used to create amazing Excel-based
applications.

Thank you so much for your continued shares,

likes and support. It really helps.