100% found this document useful (1 vote)
123 views24 pages

Bill of Materials

This document contains code for an Excel VBA application that manages an inventory and bill of materials (BOM) system. It includes code modules for assembly macros, item macros, and code within worksheet objects. The assembly macros contain procedures for building, disassembling, expanding, and shrinking assemblies. The item macros contain procedures for adding, deleting, loading, and saving item information as well as adding and removing item pictures. Various worksheets declare variables and contain event handler code for updating data.

Uploaded by

Joanne Caballes
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as PDF, TXT or read online on Scribd
100% found this document useful (1 vote)
123 views24 pages

Bill of Materials

This document contains code for an Excel VBA application that manages an inventory and bill of materials (BOM) system. It includes code modules for assembly macros, item macros, and code within worksheet objects. The assembly macros contain procedures for building, disassembling, expanding, and shrinking assemblies. The item macros contain procedures for adding, deleting, loading, and saving item information as well as adding and removing item pictures. Various worksheets declare variables and contain event handler code for updating data.

Uploaded by

Joanne Caballes
Copyright
© © All Rights Reserved
We take content rights seriously. If you suspect this is your content, claim it here.
Available Formats
Download as PDF, TXT or read online on Scribd
You are on page 1/ 24

VBA SOURCE

CODE BOOK

How To Create An Inventory


Assembly & Bill Of Materials
(BOM) Application 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 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
Admin .......................................................................................................................................................................................2
(Declarations)........................................................................................................................................................................2
AssembDB ...............................................................................................................................................................................3
(Declarations)........................................................................................................................................................................3
ItemDB .....................................................................................................................................................................................4
(Declarations)........................................................................................................................................................................4
Items ........................................................................................................................................................................................5
(Declarations)........................................................................................................................................................................5
Worksheet_Change [Sub ] ....................................................................................................................................................5
Worksheet_SelectionChange [Sub ] .....................................................................................................................................5
Sheet5......................................................................................................................................................................................7
(Declarations)........................................................................................................................................................................7
Sheet6......................................................................................................................................................................................8
(Declarations)........................................................................................................................................................................8
Sheet7......................................................................................................................................................................................9
(Declarations)........................................................................................................................................................................9
Sheet8....................................................................................................................................................................................10
(Declarations)......................................................................................................................................................................10
Sheet9 ....................................................................................................................................................................................11
(Declarations) ......................................................................................................................................................................11
ThisWorkbook ........................................................................................................................................................................12
(Declarations)......................................................................................................................................................................12
Modules .....................................................................................................................................................................................13
Assembly_macros ..................................................................................................................................................................13
(Declarations)......................................................................................................................................................................13
Assembly_Build [Sub ] ........................................................................................................................................................13
Assembly_Disassemble [Sub ] ............................................................................................................................................13
Assembly_Expand [Sub ] ....................................................................................................................................................14
Assembly_Shrink [Sub ] ......................................................................................................................................................15
Item_Macros ..........................................................................................................................................................................16
(Declarations)......................................................................................................................................................................16
Item_AddItemPic [Sub ] ......................................................................................................................................................16
Item_AddNew [Sub ] ...........................................................................................................................................................16
Item_Cancel_New [Sub ].....................................................................................................................................................16
Item_ClearItemPic [Sub ] ....................................................................................................................................................16
Item_Delete [Sub ] ..............................................................................................................................................................16
Item_Load [Sub ] .................................................................................................................................................................17
Item_SaveUpdate [Sub ] .....................................................................................................................................................17
Item_ShowPic [Sub ] ...........................................................................................................................................................18

1 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

2 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

3 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

4 of 20
T
Bill_Of_Materials.xlsm

1 Option Explicit
2
3 Private Sub Worksheet_Change(ByVal Target As Range)
4 Dim FoundItem As Range
5 Dim ItemRow As Long
6 Dim ItemNm As String
7 If Target.CountLarge > 1 Then Exit Sub
8 If Not Intersect(Target, Range("I3" )) Is Nothing And Range("I3" ).Value <> Empty Then
9 Range("D3" ).Select 'Set to Gen. Info Tab
10 Range("B3" ).Value = Range("B2" ).Value 'Item ID
11 Item_Load
12 End If
13
14 'On assembly item change
15 If Not Intersect(Target, Range("E36:E58" )) Is Nothing And Range("B6" ).Value = False Then

16 If Target.Value <> Empty Then


17 ItemNm = Target.Value
18 Set FoundItem = ItemDB.Range("Item_Name" ).Find(ItemNm, , xlValues, xlWhole)
19 If Not FoundItem Is Nothing Then 'Item found
20 ItemRow = FoundItem.Row
21 Range("F" & Target.Row).Value = ItemDB.Range("G" & ItemRow).Value 'Item
Description
22 Range("G" & Target.Row).Value = 1 'Set Default Qty to 1
23 Range("H" & Target.Row).Value = ItemDB.Range("K" & ItemRow).Value 'Item cost
24 Range("I" & Target.Row).Value = ItemDB.Range("L" & ItemRow).Value 'Sales Price

25 Else
26 MsgBox "Item not found"
27 End If
28 Else 'Cleared
29 Range("F" & Target.Row & ":I" & Target.Row).ClearContents
30 End If
31 'Update Default Assembly Costs & Sales Prices
32 Range("F11" ).Value = Range("M35" ).Value 'Update Assembly Cost
33 Range("H11" ).Value = Range("M36" ).Value 'Update Assembly Sales Price
34
35 End If
36 End Sub
37
38 Private Sub Worksheet_SelectionChange(ByVal Target As Range)
39 If Target.CountLarge > 2 Then Exit Sub
40 If Not Intersect(Target, Range("D3:F3" )) Is Nothing And Range("H5" ).Value = "Assembly"
Then
41 Range("B1" ).Value = Target.Column 'target column
42 'Hide Everything
43 Application.ScreenUpdating = False
44 Shapes("PicBtnGrp" ).Visible = msoFalse
45 Shapes("AssembGrp" ).Visible = msoFalse
46 On Error Resume Next
47 Shapes("ItemPic" ).Visible = msoFalse
48 On Error GoTo 0
49 Range("4:60" ).EntireRow.Hidden = True
50 If Target.Column = 4 Then 'General Info
51 Range("4:31" ).EntireRow.Hidden = False 'Display Rows
52 Shapes("PicBtnGrp" ).Visible = msoCTrue
53 On Error Resume Next
54 Shapes("ItemPic" ).Visible = msoCTrue
55 On Error GoTo 0
56 If Range("H5" ).Value = "Assembly" Then Shapes("ExpandBtn" ).Visible = msoCTrue
57 Range("F5" ).Select
1 2 3

5 of 20
T
Bill_Of_Materials.xlsm
1 2 3
58 Else ' Assembly
59 Range("33:60" ).EntireRow.Hidden = False 'Display Rows
60 Shapes("AssembGrp" ).Visible = msoCTrue
61 Range("E36" ).Select
62 If Range("H5" ).Value = "Assembly" Then
63 If Shapes("ShrinkBtn" ).Visible = True Then Assembly_Shrink
64 Shapes("ExpandBtn" ).Visible = msoFalse
65 End If
66 End If
67 Application.ScreenUpdating = True
68 End If
69
70 End Sub

6 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

7 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

8 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

9 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

10 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

11 of 20
Bill_Of_Materials.xlsm

1 Option Explicit
2

12 of 20
T
Bill_Of_Materials.xlsm

1 Option Explicit
2 Dim BuildQty As Long, AssembDBRow As Long, ItemRow As Long, PicRow As Long
3 Dim LastItemRow As Long, ItemDBRow As Long, QtyReq As Long, DisQty As Long
4 Dim TopPos As Double, LeftPos As Double, LeftStart As Double
5 Dim PicFolder As String, PicFile As String, AssembText As String
6 Dim ItemShp As Shape
7
8
9 Sub Assembly_Build()
10 With Items
11 If .Range("M39" ).Value > .Range("M38" ).Value Then
12 MsgBox "Please make sure the Items Set To Build Quantity is less than or equal to "
& .Range("M38" ).Value
13 Exit Sub
14 End If
15 AssembDBRow = .Range("B4" ).Value 'Assembly Database Row
16 BuildQty = .Range("M39" ).Value 'Build Quantiy
17 LastItemRow = .Range("E59" ).End(xlUp).Row
18 If LastItemRow < 37 Then
19 MsgBox "Please make sure you have added at least 2 items to build your assembly"
20 Exit Sub
21 End If
22 For ItemRow = 36 To LastItemRow
23 ItemDBRow = .Range("S" & ItemRow).Value 'Item Database Row
24 QtyReq = .Range("G" & ItemRow).Value 'Qty Required
25 If .Range("U" & ItemRow).Value <> "Service" Then ItemDB.Range("M" & ItemDBRow).
Value = ItemDB.Range("M" & ItemDBRow).Value - (QtyReq * BuildQty) 'Deduct Total
Build Qty
26 Next ItemRow
27 ItemDB.Range("M" & AssembDBRow).Value = ItemDB.Range("M" & AssembDBRow).Value +
BuildQty
28 .Range("M39" ).ClearContents 'Clear Build Qty
29 .Range("J11" ).Value = .Range("M37" ).Value 'Update Quantity On Hand
30 MsgBox BuildQty & " " & .Range("F5" ).Value & "'s assemblies have been built"
31 End With
32 End Sub
33
34
35 Sub Assembly_Disassemble()
36 With Items
37 If .Range("M40" ).Value > .Range("M37" ).Value Then
38 MsgBox "Please make sure the Items Set To Disassemble is less than or equal to " &
.Range("M37" ).Value
39 Exit Sub
40 End If
41 AssembDBRow = .Range("B4" ).Value 'Assembly Database Row
42 DisQty = .Range("M40" ).Value 'Disassemble Quantiy
43 LastItemRow = .Range("E59" ).End(xlUp).Row
44 If LastItemRow < 37 Then
45 MsgBox "Please make sure you have added at least 2 items to build your assembly"
46 Exit Sub
47 End If
48 For ItemRow = 36 To LastItemRow
49 ItemDBRow = .Range("S" & ItemRow).Value 'Item Database Row
50 QtyReq = .Range("G" & ItemRow).Value 'Qty Required
51 If .Range("U" & ItemRow).Value <> "Service" Then ItemDB.Range("M" & ItemDBRow).
Value = ItemDB.Range("M" & ItemDBRow).Value + (QtyReq * DisQty) 'Deduct Total
Build Qty
52 Next ItemRow
53 ItemDB.Range("M" & AssembDBRow).Value = ItemDB.Range("M" & AssembDBRow).Value -
DisQty
1 2

13 of 20
T
Bill_Of_Materials.xlsm
1 2
54 .Range("M40" ).ClearContents 'Clear Build Qty
55 .Range("J11" ).Value = .Range("M37" ).Value 'Update Quantity On Hand
56 MsgBox DisQty & " " & .Range("F5" ).Value & "'s assemblies have been disassembled"
57 End With
58 End Sub
59
60 Sub Assembly_Expand()
61 With Items
62 'Delete existing Assembly Item Shapes (if any)
63 For Each ItemShp In .Shapes
64 If InStr(ItemShp.Name, "AssembPic" ) > 0 Then ItemShp.Delete
65 Next ItemShp
66 PicFolder = Admin.Range("C4" ).Value 'Picture folder
67 LastItemRow = Application.WorksheetFunction.CountA(Items.Range("E36:E58" )) + 35
68 If LastItemRow < 37 Then Exit Sub
69 LeftStart = .Range("E17" ).Left
70 LeftPos = .Range("E17" ).Left
71 TopPos = .Range("E17" ).Top
72 PicRow = 1 'Set intial Picture row
73 For ItemRow = 36 To LastItemRow
74 ItemDBRow = .Range("S" & ItemRow).Value 'Item Database Row
75 PicFile = PicFolder & "\" & ItemDB.Range("N" & ItemDBRow).Value 'Picture Path
76 If Dir(PicFile, vbDirectory) = "" Then GoTo NextItem
77 .Pictures.Insert(PicFile).Name = "AssembPic" & ItemRow
78 With .Shapes("AssembPic" & ItemRow)
79 .Left = LeftPos
80 .Top = TopPos
81 .LockAspectRatio = msoCTrue
82 .Width = 60
83 End With
84
85 'Create & Position Connector
86 .Shapes("ConSample" ).Duplicate.Name = "AssembPicCon" & ItemRow
87 With .Shapes("AssembPicCon" & ItemRow).ConnectorFormat
88 If PicRow = 1 Then 'Top Row
89 .BeginConnect Items.Shapes("ShrinkBtn" ), 3
90 Else 'All Other row
91 .BeginConnect Items.Shapes("AssembPicText" & ItemRow - 8), 3
92 End If
93 .EndConnect Items.Shapes("AssembPic" & ItemRow), 1
94 End With
95
96 'Create & Position text box
97 AssembText = .Range("G" & ItemRow).Value & "-" & .Range("E" & ItemRow).Value
98 .Shapes("TextBoxSample" ).Duplicate.Name = "AssembPicText" & ItemRow
99 With .Shapes("AssembPicText" & ItemRow)
100 .Left = LeftPos
101 .Top = TopPos + 62
102 .TextFrame2.TextRange.Text = AssembText 'Add Qty & Item Name
103 End With
104
105
106 'Update Left & Top Position
107 If LeftPos > .Range("L17" ).Left Then
108 TopPos = TopPos + 105
109 LeftPos = LeftStart 'Set Back to initial left post
110 PicRow = PicRow + 1
111 Else
112 LeftPos = LeftPos + 90
113 End If
114 NextItem:
1 2 3

14 of 20
T
Bill_Of_Materials.xlsm
1 2 3
115 Next ItemRow
116 .Shapes("ExpandBtn" ).Visible = msoFalse
117 .Shapes("ShrinkBtn" ).Visible = msoCTrue
118 End With
119 End Sub
120
121
122 Sub Assembly_Shrink()
123 With Items
124 For Each ItemShp In .Shapes
125 If InStr(ItemShp.Name, "AssembPic" ) > 0 Then ItemShp.Delete
126 Next ItemShp
127 .Shapes("ShrinkBtn" ).Visible = msoFalse
128 .Shapes("ExpandBtn" ).Visible = msoCTrue
129 End With
130 End Sub

15 of 20
T
Bill_Of_Materials.xlsm

1 Option Explicit
2 Dim ItemRow As Long, ItemCol As Long, LastRow As Long, LastResultRow As Long, LastAssembRow
As Long, AssembDBRow As Long, AssembRow As Long
3 Dim ItemID As String, PicFile As String, ItemPicFolder As String, PicPath As String,
ResultRow As Long
4 Dim ItemFilePic As FileDialog
5 Dim ItemShp As Shape
6
7 Sub Item_AddItemPic()
8 ItemPicFolder = Admin.Range("C4" ).Value 'Item Picture folder
9 If Dir(ItemPicFolder, vbDirectory) = "" Then
10 MsgBox "Please add a picture file path inside the Admin screen before adding picture"
11 Exit Sub
12 End If
13 With Items
14 Set ItemFilePic = Application.FileDialog(msoFileDialogFilePicker)
15 With ItemFilePic
16 .Title = "Please select an Item picture"
17 .Filters.Add "Picture Files" , "*.jpg,*.png,*.gif" , 1
18 .AllowMultiSelect = False
19 If .Show <> -1 Then GoTo NoSelection
20 PicPath = .SelectedItems(1)
21 End With
22 .Range("L6 " ).Value = Dir(PicPath) 'Set Name (Extracts File Name from file path)
23 On Error Resume Next
24 FileCopy PicPath, ItemPicFolder & "\" & Dir(PicPath) 'Copy picture to app Item
picture folder
25 On Error GoTo 0
26 Item_ShowPic
27 End With
28 NoSelection:
29 End Sub
30 Sub Item_AddNew()
31 With Items
32 'Delete existing Assembly Item Shapes (if any)
33 For Each ItemShp In .Shapes
34 If InStr(ItemShp.Name, "AssembPic" ) > 0 Then ItemShp.Delete
35 Next ItemShp
36 .Range("ItemData" ).ClearContents 'Clear all of the data those cells
37 .Shapes("ExpandBtn" ).Visible = msoFalse
38 .Shapes("ShrinkBtn" ).Visible = msoFalse
39 .Range("B3" ).ClearContents
40 .Shapes("NewItemGrp" ).Visible = msoCTrue
41 .Shapes("ExistItemGrp" ).Visible = msoFalse
42 Item_ClearItemPic
43 End With
44 End Sub
45
46 Sub Item_Cancel_New()
47 If ItemDB.Range("B4" ).Value <> Empty Then Items.Range("I3" ).Value = ItemDB.Range("B4" ).
Value 'Set First Item Name To Load
48 End Sub
49 Sub Item_ClearItemPic()
50 On Error Resume Next
51 Items.Shapes("ItemPic" ).Delete
52 On Error GoTo 0
53 Items.Range("L6" ).ClearContents 'Clear picture cell
54 End Sub
55
56 Sub Item_Delete()
57 If MsgBox("Are you sure you want to delete this item?" , vbYesNo, "Delete Item" ) = vbNo
1

16 of 20
T
Bill_Of_Materials.xlsm
1
Then Exit Sub
58 With Items
59 If .Range("B4" ).Value = Empty Then
60 MsgBox "Please select a correct Item from the list on the left"
61 Exit Sub
62 End If
63 ItemRow = .Range("B4" ).Value 'Set Item Row
64 ItemDB.Range(ItemRow & ":" & ItemRow).Delete
65 Item_AddNew
66 MsgBox "Item has been deleted"
67 End With
68 End Sub
69
70
71 Sub Item_Load()
72 With Items
73 .Range("ItemData" ).ClearContents 'Clear all of the data those cells
74 If .Range("B4" ).Value = Empty Then
75 MsgBox "Please select a correct Item from the list on the left"
76 Exit Sub
77 End If
78 'Delete existing Assembly Item Shapes (if any)
79 For Each ItemShp In .Shapes
80 If InStr(ItemShp.Name, "AssembPic" ) > 0 Then ItemShp.Delete
81 Next ItemShp
82 .Shapes("ExpandBtn" ).Visible = msoFalse 'Hide Expand button by default
83 .Shapes("ShrinkBtn" ).Visible = msoFalse 'Hide Expand button by default
84 ItemPicFolder = Admin.Range("C4" ).Value 'Item Picture folder
85 ItemRow = .Range("B4" ).Value 'Set Item Row
86 For ItemCol = 2 To 15 'Load Item Data
87 .Range(ItemDB.Cells(1, ItemCol).Value).Value = ItemDB.Cells(ItemRow, ItemCol).Value
88 Next ItemCol
89 If .Range("B1" ).Value = 4 Then Item_ShowPic 'Add item pic if avail and in Gen. Info
tab
90 If .Range("H5" ).Value = "Assembly" Then 'Load Assembly Items
91 LastAssembRow = AssembDB.Range("A999999" ).End(xlUp).Row
92 If LastAssembRow < 3 Then GoTo NoItems
93 .Shapes("ExpandBtn" ).Visible = msoCTrue 'Show Expand Button
94 AssembDB.Range("A2:E" & LastAssembRow).AdvancedFilter xlFilterCopy, CriteriaRange:=
AssembDB.Range("G2:G3" ), CopyToRange:=AssembDB.Range("I2:L2" ), Unique:=True
95 LastResultRow = AssembDB.Range("I99999" ).End(xlUp).Row
96 If LastResultRow < 3 Then Exit Sub
97 For ResultRow = 3 To LastResultRow
98 ItemRow = AssembDB.Range("K" & ResultRow).Value
99 .Range("E" & ItemRow).Value = AssembDB.Range("I" & ResultRow).Value 'Item Name

100 .Range("G" & ItemRow).Value = AssembDB.Range("J" & ResultRow).Value 'Qty


Required
101 .Range("R" & ItemRow).Value = AssembDB.Range("L" & ResultRow).Value 'Database
Row
102 Next ResultRow
103 NoItems:
104 End If
105 .Shapes("NewItemGrp" ).Visible = msoFalse
106 .Shapes("ExistItemGrp" ).Visible = msoCTrue
107 End With
108 End Sub
109
110 Sub Item_SaveUpdate()
111 With Items
112 If .Range("F5" ).Value = Empty Then
1 2 3

17 of 20
T
Bill_Of_Materials.xlsm
1 2 3
113 MsgBox "Please make sure to add an Item Name to your Item before saving"
114 Exit Sub
115 End If
116 If .Range("B4" ).Value = Empty Then 'New Item
117 ItemRow = ItemDB.Range("A99999" ).End(xlUp).Row + 1 'First Avail Row.
118 .Range("B3" ).Value = .Range("B5" ).Value 'Item ID
119 ItemDB.Range("A" & ItemRow).Value = .Range("B5" ).Value 'Item ID
120 Else 'Existing Item
121 ItemRow = .Range("B4" ).Value 'Item Row
122 End If
123
124 For ItemCol = 2 To 15
125 ItemDB.Cells(ItemRow, ItemCol).Value = .Range(ItemDB.Cells(1, ItemCol).Value).Value
'Save Data to DB
126 Next ItemCol
127
128 'Check For Assembly & Items
129 If .Range("H5" ).Value = "Assembly" Then
130 LastAssembRow = .Range("E59" ).End(xlUp).Row 'Last Assembly Item Row
131 If LastAssembRow < 36 Then GoTo NoItems
132 For AssembRow = 36 To LastAssembRow
133 If .Range("R" & AssembRow).Value = "" Then 'New Item
134 AssembDBRow = AssembDB.Range("A999999" ).End(xlUp).Row + 1 ' First Avail Row
135 AssembDB.Range("A" & AssembDBRow).Value = .Range("B3" ).Value 'Item ID
136 AssembDB.Range("D" & AssembDBRow).Value = AssembRow 'Assembly Item row
137 AssembDB.Range("E" & AssembDBRow).Value = "=Row()" 'Assemb DB Row
138 .Range("R" & AssembRow).Value = AssembDBRow
139 Else 'Existing
140 AssembDBRow = .Range("R" & AssembRow).Value 'Existing Assemb. DB Row
141 End If
142 AssembDB.Range("B" & AssembDBRow).Value = .Range("E" & AssembRow).Value 'Item
Name
143 AssembDB.Range("C" & AssembDBRow).Value = .Range("G" & AssembRow).Value 'Item
Qty
144 Next AssembRow
145 End If
146 NoItems:
147 .Shapes("NewItemGrp" ).Visible = msoFalse 'Hide New Item group
148 .Shapes("ExistItemGrp" ).Visible = msoCTrue 'Show existing item grou
149 End With
150 End Sub
151
152 Sub Item_ShowPic()
153 With Items
154 On Error Resume Next
155 .Shapes("ItemPic" ).Delete
156 On Error GoTo 0
157 If .Range("L6" ).Value = Empty Then Exit Sub
158 PicPath = Admin.Range("C4" ).Value & "\" & .Range("L6" ).Value 'Full Picture Path
159 If Dir(PicPath, vbDirectory) = "" Then
160 MsgBox "Picture name or folder is incorrect"
161 Exit Sub
162 End If
163 .Pictures.Insert(PicPath).Name = "ItemPic"
164 With .Shapes("ItemPic" )
165 .LockAspectRatio = msoCTrue
166 If .Width > .Height Then .Width = 90 Else .Height = 90
167 .Left = Items.Range("L7" ).Left + (Items.Range("L:M" ).Width - .Width) / 2
'Centered Left Pos
168 .Top = Items.Range("L7" ).Top + (Items.Range("7:14" ).Height - .Height) / 2
'Centered Top Pos
1 2 3

18 of 20
T
Bill_Of_Materials.xlsm
1 2 3
169 .Visible = msoCTrue
170 End With
171 End With
172 End Sub

19 of 20
Index
ItemNm, 5
A ItemPicFolder, 16, 17 W
Add, 16 ItemRow, 5, 13-18 Width, 14, 18
Admin, 14, 16-18 Items, 13-18 Worksheet_Change, 5
AdvancedFilter, 17 ItemShp, 13-17 Worksheet_SelectionChange, 5
AllowMultiSelect, 16 WorksheetFunction, 14
Application, 5, 6, 14, 16 L
AssembDB, 17, 18 LastAssembRow, 16-18 X
AssembDBRow, 13, 16, 18 LastItemRow, 13, 14 xlFilterCopy, 17
Assembly_Build, 13 LastResultRow, 16, 17 xlUp, 13, 17, 18
Assembly_Disassemble, 13 LastRow, 16 xlValues, 5
Assembly_Expand, 14 Left, 14, 18 xlWhole, 5
Assembly_Shrink, 6, 15 LeftPos, 13, 14
AssembRow, 16, 18 LeftStart, 13, 14
AssembText, 13, 14 LockAspectRatio, 14, 18

B M
BeginConnect, 14 MsgBox, 5, 13, 14, 16-18
BuildQty, 13 msoCTrue, 5, 6, 14-19
msoFalse, 5, 6, 15-18
C msoFileDialogFilePicker, 16
Cells, 17, 18
ClearContents, 5, 13, 14, 16, 17 N
Column, 5 Name, 14-18
ConnectorFormat, 14 NextItem, 14
CopyToRange, 17 NoItems, 17, 18
CountA, 14 NoSelection, 16
CountLarge, 5
CriteriaRange, 17 P
PicFile, 13, 14, 16
D PicFolder, 13, 14
Delete, 14-18 PicPath, 16, 18
Dir, 14, 16, 18 PicRow, 13, 14
DisQty, 13, 14 Pictures, 14, 18
Duplicate, 14
Q
E QtyReq, 13
Empty, 5, 16-18
EndConnect, 14 R
EntireRow, 5, 6 Range, 5, 6, 13, 14, 16-18
Explicit, 2-5, 7-13, 16 ResultRow, 16, 17
Row, 5, 13, 17, 18
F
FileCopy, 16 S
FileDialog, 16 ScreenUpdating, 5, 6
Filters, 16 SelectedItems, 16
Find, 5 Shape, 13, 16
FoundItem, 5 Shapes, 5, 6, 14-18
Show, 16
H
Height, 18 T
Hidden, 5, 6 Target, 5
Text, 14
I TextFrame2, 14
Insert, 14, 18 TextRange, 14
InStr, 14-17 Title, 16
Intersect, 5 Top, 14, 18
Item_AddItemPic, 16 TopPos, 13, 14
Item_AddNew, 16, 17
Item_Cancel_New, 16 U
Item_ClearItemPic, 16 Unique, 17
Item_Delete, 16
Item_Load, 5, 17 V
Item_SaveUpdate, 17 Value, 5, 6, 13, 14, 16-18
Item_ShowPic, 16-18 vbDirectory, 14, 16, 18
ItemCol, 16-18 vbNo, 16
ItemDB, 5, 13, 14, 16-18 vbYesNo, 16
ItemDBRow, 13, 14 Visible, 5, 6, 15-19
ItemFilePic, 16
ItemID, 16

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

You might also like