VBA SOURCE

CODE BOOK

How To Create A 1-Click

Record Quick View Pop-Up
For Any Table In Excel

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

DISCORD 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 200 of my BEST Applications

into a SINGLE ZIP File which also includes the "200
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
Customers ................................................................................................................................................................................2
(Declarations)........................................................................................................................................................................2
Worksheet_SelectionChange [Sub ] .....................................................................................................................................2
InvoiceItems .............................................................................................................................................................................3
(Declarations)........................................................................................................................................................................3
Invoices ....................................................................................................................................................................................4
(Declarations)........................................................................................................................................................................4
Worksheet_SelectionChange [Sub ] .....................................................................................................................................4
Setup........................................................................................................................................................................................5
(Declarations)........................................................................................................................................................................5
Worksheet_Change [Sub ] ....................................................................................................................................................5
Worksheet_SelectionChange [Sub ] .....................................................................................................................................5
ThisWorkbook ..........................................................................................................................................................................6
(Declarations)........................................................................................................................................................................6
Modules .......................................................................................................................................................................................7
QuickView_Macros ...................................................................................................................................................................7
(Declarations)........................................................................................................................................................................7
QuickView_Create [Sub ] ......................................................................................................................................................7
QuickView_Delete [Sub ] ......................................................................................................................................................9
Setup_Macros ........................................................................................................................................................................10
(Declarations)......................................................................................................................................................................10
ListAllSheets [Sub ] .............................................................................................................................................................10
Setup_SetTheme [Sub ] ......................................................................................................................................................10

1 of 11
T
1-Click_Quick_View.xlsm

1 Option Explicit
2
3 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
4 If Not Intersect(Target, Range("A3:Z999" )) Is Nothing And Range("A" & [Link]).Value
<> Empty Then
5 [Link]("E5" ).Value = [Link]
6 QuickView_Create
7 End If
8 End Sub

2 of 11
 1-Click_Quick_View.xlsm

1 Option Explicit

3 of 11
T
1-Click_Quick_View.xlsm

1 Option Explicit
2
3 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
4 If Not Intersect(Target, Range("A3:Z999" )) Is Nothing And Range("A" & [Link]).Value
<> Empty Then
5 [Link]("E5" ).Value = [Link]
6 QuickView_Create
7 End If
8
9 End Sub

4 of 11
T
1-Click_Quick_View.xlsm

1 Option Explicit
2
3 Private Sub Worksheet_Change(ByVal Target As Range)
4 If Not Intersect(Target, Range("G5:H99" )) Is Nothing And Range("G" & [Link]).Value <
> Empty And Range("H" & [Link]).Value <> Empty Then
5 If IsNumeric(Range("H" & [Link]).Value) = False Then Exit Sub 'Header Row must be
numeric value
6 Dim ShtNm As String
7 Dim HeadRow As Long, HeadCol As Long, ShtCol As Long, FirstCol As Long, LastCol As
Long, SetupCol As Long, SetupRow As Long
8 HeadRow = Range("H" & [Link]) 'Header Row
9 ShtNm = Range("G" & [Link]).Value 'Worksheet Name
10 SetupCol = Range("U4:AB4" ).Find(ShtNm, , xlValues, xlWhole).Column
11 SetupRow = 5
12 Range(Cells(5, SetupCol), Cells(34, SetupCol)).ClearContents 'Clear Previous headers
13 LastCol = [Link](ShtNm).Cells(HeadRow, 23).End(xlToLeft).Column 'Last
Column With a value
14 FirstCol = [Link](ShtNm).Cells(HeadRow, 1).End(xlToRight).Column
15 If FirstCol = LastCol Then FirstCol = 1 'Set to First Column on no blank columns
16 Range("I" & [Link]).Value = FirstCol 'Set Default First Col.
17 Range("J" & [Link]).Value = LastCol 'Set Default Last Col.
18 For HeadCol = FirstCol To LastCol 'loop through all column headers
19 Cells(SetupRow, SetupCol).Value = [Link](ShtNm).Cells(HeadRow, HeadCol)
.Value 'Header Row value
20 SetupRow = SetupRow + 1
21 Next HeadCol
22 On Error Resume Next
23 [Link](ShtNm).Names(Replace(ShtNm, " " , "_" ) & "_Headers" ).Delete
24 On Error GoTo 0
25 [Link] Replace(ShtNm, " " , "_" ) & "_Headers" , "=" & Range(Cells(5,
SetupCol), Cells(SetupRow - 1, SetupCol)).Address
26 Range("K" & [Link]).[Link]
27 Range("N" & [Link]).[Link]
28 Range("K" & [Link]).[Link] xlValidateList, xlValidAlertStop, , Formula1:=
"=" & Replace(ShtNm, " " , "_" ) & "_Headers"
29 Range("N" & [Link]).[Link] xlValidateList, xlValidAlertStop, , Formula1:=
"=" & Replace(ShtNm, " " , "_" ) & "_Headers"
30 End If
31 End Sub
32
33 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
34 If Shapes("ThemeGrp" ).Visible = True Then Shapes("ThemeGrp" ).Visible = msoFalse 'Hide
Theme Group
35 If [Link] > 1 Then Exit Sub
36 If Not Intersect(Target, Range("E3" )) Is Nothing Then Shapes("ThemeGrp" ).Visible =
msoCTrue
37 End Sub

5 of 11
 1-Click_Quick_View.xlsm

1 Option Explicit
2

6 of 11
T
1-Click_Quick_View.xlsm

1 Option Explicit
2 Dim ShtNm As String, ShapeGrp As String, ShapeArr() As String, PicField As String, PicName As
String, PicFolder As String, PicPath As String
3 Dim LinkedSht As String, LinkedID As String
4 Dim TopPos As Double, LeftPos As Double
5 Dim ActRow As Long, ActCol As Long, DetailRow As Long, HeadRow As Long, DataCol As Long,
StartCol As Long, EndCol As Long, LinkIDDataCol As Long
6 Dim LastRow As Long, LastCol As Long, LastResultRow As Long, LastResultCol As Long,
LastDataCol As Long
7 Dim QVGroup As Shape
8 Dim ResultRng As Range
9
10 Sub QuickView_Create()
11 With ActiveSheet
12 ShtNm = [Link] 'Active Sheet Name
13 If [Link] = "Setup" Then
14 MsgBox "Please run this on sheets other than the Setup sheet"
15 Exit Sub
16 End If
17 On Error Resume Next
18 [Link]("QuickViewGrp" ).Delete
19 On Error GoTo 0
20 ShapeGrp = "" 'Clear ShapeGrp
21 ActRow = [Link] 'Active Row
22 ActCol = [Link] 'Active Column
23 On Error Resume Next
24 DetailRow = [Link]("G5:G34" ).Find(ShtNm, , xlValues, xlWhole).Row
25 On Error GoTo 0
26 If DetailRow = 0 Then
27 MsgBox "Please make sure to setup this sheet in the Quick View Table in the Setup
Sheet"
28 Exit Sub
29 End If
30 'Header Row, Start Column, Ending Col area all required
31 If [Link]("H" & DetailRow).Value = "" Or [Link]("I" & DetailRow).Value =
"" Or [Link]("J" & DetailRow).Value = "" Then
32 MsgBox "Pelase make sure the Quick View detail row contains a header row along with
starting and ending columns"
33 Exit Sub
34 End If
35 [Link] = False
36 [Link] = False
37 HeadRow = [Link]("H" & DetailRow).Value 'Header Row
38 StartCol = [Link]("I" & DetailRow).Value 'Start Col
39 EndCol = [Link]("J" & DetailRow).Value 'End Column
40 If [Link]("K" & DetailRow).Value <> "" Then
41 PicField = [Link]("K" & DetailRow).Value 'Picture File Name
42 End If
43 If [Link]("L" & DetailRow).Value <> "" Then
44 PicFolder = [Link]("L" & DetailRow).Value & "/" 'Picture Folder
45 End If
46 LeftPos = [Link](0, 1).Left 'Set Initial Left Pos
47 TopPos = [Link](0, 1).Top 'Set Initial Top Pos
48 [Link]("SampleBack" ).Copy
49 [Link]
50 [Link] = "QV_" & ShtNm
51 With .Shapes("QV_" & ShtNm)
52 .[Link] = ShtNm & "- Quick View"
53 .Left = LeftPos
54 .Top = TopPos
55 .Width = [Link]("E4" ).Value 'Set Quik View Background width
1 2 3

7 of 11
T
1-Click_Quick_View.xlsm
1 2 3
56 End With
57 LeftPos = LeftPos + 5
58 TopPos = TopPos + 30
59 [Link]("SampleLbl" ).Copy
60 [Link]
61 [Link]("SampleFld" ).Copy
62 [Link]
63 [Link]("CloseIcon" ).Copy
64 [Link]
65 .Shapes("CloseIcon" ).Left = [Link]("QV_" & ShtNm).Left + ActiveSheet.
Shapes("QV_" & ShtNm).Width - 15 'Place Close Button
66 ShapeGrp = "QV_" & ShtNm & ",CloseIcon"
67
68 'Set Fileds
69 For DataCol = StartCol To EndCol
70 .Shapes("SampleLbl" ).[Link] = "Label" & DataCol 'Create Label
71 With .Shapes("Label" & DataCol)
72 .Left = LeftPos 'Set Left Pos
73 .Width = 50
74 .Top = TopPos 'Set Top Pos
75 .[Link] = [Link](HeadRow, DataCol).Value 'Set
Header Label
76 ShapeGrp = ShapeGrp & ",Label" & DataCol
77 End With
78 If PicField = [Link](HeadRow, DataCol).Value Then 'Check For Picture
data type
79 PicName = [Link](ActRow, DataCol).Value 'Pictgure Name
80 If PicName <> Empty Then PicPath = PicFolder & PicName 'Picture Path
81 If Dir(PicPath, vbDirectory) = "" Then GoTo NextField
82 .[Link](PicPath).Name = "Field" & DataCol
83 Else 'Not Picture (text Field)
84 .Shapes("SampleFld" ).[Link] = "Field" & DataCol
85 End If
86 On Error Resume Next
87 With .Shapes("Field" & DataCol)
88 .Left = LeftPos + 55 'Set Left Pos
89 .Width = 190
90 .[Link] = [Link](ActRow, DataCol).Value 'Set Value

91 .[Link] = msoAutoSizeShapeToFitText 'Automate Height of shape

92 .Top = TopPos 'Set Top Pos
93 ShapeGrp = ShapeGrp & ",Field" & DataCol
94 End With
95 TopPos = .Shapes("Field" & DataCol).Top + .Shapes("Field" & DataCol).Height + 4
96 On Error GoTo 0
97 LastDataCol = DataCol
98 NextField:
99 Next DataCol
100
101 'Check For Linked Tables
102 If [Link]("M" & DetailRow).Value <> Empty And [Link]("N" & DetailRow).Value
<> Empty Then
103 LinkedSht = [Link]("M" & DetailRow).Value 'Linked Sheet
104 LinkedID = [Link]("N" & DetailRow).Value 'Linked ID
105 On Error Resume Next
106 LinkIDDataCol = Range(Sheets(ShtNm).Cells(HeadRow, 1), Sheets(ShtNm).Cells(HeadRow,
EndCol)).Find(LinkedID, , xlValues, xlWhole).Column
107 On Error GoTo 0
108 If LinkIDDataCol = 0 Then GoTo NoData
109
110 With Sheets(LinkedSht)
1 2 3 4

8 of 11
T
1-Click_Quick_View.xlsm
1 2 3 4
111 LastRow = .Range("A99999" ).End(xlUp).Row ' Last Row
112 If LastRow < 3 Then GoTo NoData
113 .Range("Y2" ).Value = Worksheets(ShtNm).Cells(HeadRow, LinkIDDataCol).Value
'Criteria Header
114 .Range("Y3" ).Value = Worksheets(ShtNm).Cells(ActRow, LinkIDDataCol).Value
'Criteria Value
115 .Range("A" & HeadRow & ":X" & LastRow).AdvancedFilter xlFilterCopy,
CriteriaRange:=.Range("Y2:Y3" ), CopyToRange:=.Range("AA2:AX2" ), Unique:=True
116 LastResultRow = .Range("AA99999" ).End(xlUp).Row
117 If LastResultRow < 3 Then GoTo NoData
118 LastResultCol = .Range("AZ2" ).End(xlToLeft).Column
119 Set ResultRng = Range(.Cells(1, 27), .Cells(LastResultRow, LastResultCol)) 'Set
Our results data range
120 [Link] 'Copy results as a picture
121 [Link]
122 [Link]
123 End With
124
125 [Link] = "LinkedTable" 'Assign to table
126 .Shapes("QV_" & ShtNm).Width = .Shapes("QV_" & ShtNm).Width + .Shapes(
"LinkedTable" ).Width + 2
127 With .Shapes("LinkedTable" )
128 .Top = [Link]("Field" & StartCol).Top
129 .Left = [Link]("Field" & StartCol).Left + [Link](
"Field" & StartCol).Width + 10
130 End With
131 .Shapes("CloseIcon" ).Left = [Link]("QV_" & ShtNm).Left + ActiveSheet.
Shapes("QV_" & ShtNm).Width - 15 'Update close button
132 ShapeGrp = ShapeGrp & ",LinkedTable" 'Update Shape Group String
133
134 NoData:
135 End If
136
137 'Create Shape Group
138 .Shapes("QV_" & ShtNm).Height = .Shapes("Field" & LastDataCol).Top + .Shapes("Field"
& LastDataCol).Height - .Shapes("QV_" & ShtNm).Top + 20 'Set Height Of Background
139 .Shapes("SampleLbl" ).Delete
140 .Shapes("SampleFld" ).Delete
141 ShapeArr = Split(ShapeGrp, "," )
142 Set QVGroup = .[Link](ShapeArr).Group
143 [Link] = "QuickViewGrp"
144 End With
145 [Link] = True
146 [Link] = True
147 End Sub
148
149 Sub QuickView_Delete()
150 On Error Resume Next
151 [Link]("QuickViewGrp" ).Delete
152 On Error GoTo 0
153 [Link]("E5" ).ClearContents 'Clear selected row cell
154 [Link] = True
155 End Sub

9 of 11
T
1-Click_Quick_View.xlsm

1 Option Explicit
2 Dim WkSht As Worksheet
3 Dim ShtRow As Long
4 Sub ListAllSheets()
5 [Link]("B4:B999" ).ClearContents
6 ShtRow = 4
7 For Each WkSht In [Link]
8 [Link]("B" & ShtRow).Value = [Link]
9 ShtRow = ShtRow + 1
10 Next WkSht
11 End Sub
12
13 Sub Setup_SetTheme()
14 Dim ThemeNumb As Long
15 ThemeNumb = Replace([Link], "Style" , "" )
16 [Link]("SampleBack" ).ShapeStyle = ThemeNumb
17 With [Link]("E3" ).Interior
18 .Pattern = xlSolid
19 .PatternColorIndex = xlAutomatic
20 Select Case ThemeNumb
21 Case Is = 22
22 .ThemeColor = xlThemeColorDark1
23 Case Is = 23
24 .ThemeColor = xlThemeColorAccent1
25 Case Is = 24
26 .ThemeColor = xlThemeColorAccent2
27 Case Is = 25
28 .ThemeColor = xlThemeColorAccent3
29 Case Is = 26
30 .ThemeColor = xlThemeColorAccent4
31 Case Is = 27
32 .ThemeColor = xlThemeColorAccent5
33 Case Is = 28
34 .ThemeColor = xlThemeColorAccent6
35 End Select
36 .TintAndShade = 0.599993896298105
37 .PatternTintAndShade = 0
38 End With
39 [Link]("ThemeGrp" ).Visible = msoFalse
40 [Link]("E4" ).Select
41 End Sub

10 of 11
 Index
msoAutoSizeShapeToFitText, 8
A msoCTrue, 5 V
ActCol, 7 msoFalse, 5, 10 Validation, 5
ActiveCell, 7, 9 Value, 2, 4, 5, 7-10
ActiveSheet, 7-9 N vbDirectory, 8
ActRow, 7-9 Name, 7-10 Visible, 5, 10
Add, 5 Names, 5
Address, 5 NextField, 8 W
AdvancedFilter, 9 NoData, 8, 9 Width, 7-9
Application, 7, 9, 10 WkSht, 10
AutoSize, 8 O Worksheet, 10
Offset, 7 Worksheet_Change, 5
C Worksheet_SelectionChange, 2, 4, 5
Caller, 10 P Worksheets, 9, 10
Cells, 5, 8, 9 Paste, 7-9
ClearContents, 5, 9, 10 Pattern, 10 X
Column, 5, 7-9 PatternColorIndex, 10 xlAutomatic, 10
Copy, 7, 8 PatternTintAndShade, 10 xlFilterCopy, 9
CopyPicture, 9 PicField, 7, 8 xlSolid, 10
CopyToRange, 9 PicFolder, 7, 8 xlThemeColorAccent1, 10
CountLarge, 5 PicName, 7, 8 xlThemeColorAccent2, 10
CriteriaRange, 9 PicPath, 7, 8 xlThemeColorAccent3, 10
Pictures, 8 xlThemeColorAccent4, 10
D xlThemeColorAccent5, 10
DataCol, 7, 8 Q xlThemeColorAccent6, 10
Delete, 5, 7, 9 QuickView_Create, 2, 4, 7 xlThemeColorDark1, 10
DetailRow, 7, 8 QuickView_Delete, 9 xlToLeft, 5, 9
Dir, 8 QVGroup, 7, 9 xlToRight, 5
Duplicate, 8 xlUp, 9
R xlValidAlertStop, 5
E Range, 2, 4, 5, 7-10 xlValidateList, 5
Empty, 2, 4, 5, 8 Replace, 5, 10 xlValues, 5, 7, 8
EnableEvents, 7, 9 ResultRng, 7, 9 xlWhole, 5, 7, 8
EndCol, 7, 8 Row, 2, 4, 5, 7, 9
Explicit, 2-7, 10
S
F ScreenUpdating, 7, 9
Find, 5, 7, 8 Selection, 7, 9
FirstCol, 5 Setup, 2, 4, 5, 7-10
Formula1, 5 Setup_SetTheme, 10
SetupCol, 5
G SetupRow, 5
Group, 9 Shape, 7
ShapeArr, 7, 9
H ShapeGrp, 7-9
HeadCol, 5 Shapes, 5, 7-10
HeadRow, 5, 7-9 ShapeStyle, 10
Height, 8, 9 Sheets, 5, 8
ShtCol, 5
I ShtNm, 5, 7-9
Insert, 8 ShtRow, 10
Interior, 10 Split, 9
Intersect, 2, 4, 5 StartCol, 7-9
IsNumeric, 5
T
L Target, 2, 4, 5
LastCol, 5, 7 Text, 7, 8
LastDataCol, 7-9 TextFrame2, 7, 8
LastResultCol, 7, 9 TextRange, 7, 8
LastResultRow, 7, 9 ThemeColor, 10
LastRow, 7, 9 ThemeNumb, 10
Left, 7-9 ThisWorkbook, 5, 10
LeftPos, 7, 8 TintAndShade, 10
LinkedID, 7, 8 Top, 7-9
LinkedSht, 7, 8 TopPos, 7, 8
LinkIDDataCol, 7-9
ListAllSheets, 10 U
Unique, 9
M
MsgBox, 7

11 of 11
 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.