Skip to content

Commit 4bd988a

Browse files
vzhomeexperimentsvzhomeexperiments
authored
Add files via upload
1 parent 9c0b3f0 commit 4bd988a

File tree

6 files changed

+482
-0
lines changed

6 files changed

+482
-0
lines changed

‎1_InvokeUF.txt

Lines changed: 22 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,22 @@
1+
' ==================================================================================================
2+
' Purpose of this code is to invoke the User Form when user double click the line on the spreadsheet
3+
' ==================================================================================================
4+
5+
Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
6+
7+
' Define variables needed
8+
Dim iRow As Integer
9+
' Initialize variables
10+
iRow = Target.Row
11+
12+
' Update Inputs in the form
13+
UpdateInputs iRow
14+
15+
' Cancel = false means form can not be modified together with cell
16+
Cancel = True
17+
18+
'possible to modify cell when the form is up
19+
MyCarCheckListForm.Show False
20+
21+
End Sub
22+

‎CheckList_CaseStudy1.xlsm

2.55 MB
Binary file not shown.

‎Functions.bas

Lines changed: 114 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,114 @@
1+
Attribute VB_Name = "Functions"
2+
' (C) 2017 VZ Home Experiments Vladimir Zhbanko //[email protected]
3+
' VBA code to make work with Excel User Forms easier
4+
' More time to spend on more interesting stuff.
5+
6+
'========================================
7+
' FUNCTION that keep First available Capital letter in the string
8+
'========================================
9+
Function getFirstCapitalLetter(myInput As String) As String
10+
' Declaring variables
11+
Dim myResult As String ' This is the return string
12+
Dim i As Long ' Counter for character position
13+
14+
' Initialise return string to empty
15+
myResult = ""
16+
17+
' For every character in input string, copy digits to
18+
' return string if they are passing criteria
19+
For i = 1 To Len(myInput)
20+
If Mid(myInput, i, 1) >= "A" And Mid(myInput, i, 1) <= "Z" Then
21+
myResult = myResult + Mid(myInput, i, 1)
22+
Exit For
23+
End If
24+
Next
25+
26+
' Then return the return string. '
27+
getFirstCapitalLetter = myResult
28+
End Function
29+
30+
'========================================
31+
' FUNCTION that keep All available Capital letters in the string
32+
'========================================
33+
Function getAllCapitalLetters(myInput As String) As String
34+
' Declaring variables
35+
Dim myResult As String ' This is the return string
36+
Dim i As Long ' Counter for character position
37+
38+
' Initialise return string to empty
39+
myResult = ""
40+
41+
' For every character in input string, copy digits to
42+
' return string if they are passing criteria
43+
For i = 1 To Len(myInput)
44+
If Mid(myInput, i, 1) >= "A" And Mid(myInput, i, 1) <= "Z" Then
45+
myResult = myResult + Mid(myInput, i, 1)
46+
End If
47+
Next
48+
49+
' Then return the return string. '
50+
getAllCapitalLetters = myResult
51+
End Function
52+
'========================================
53+
' FUNCTION that removes all text from string, and leave only numbers
54+
'========================================
55+
Function getOnlyDigit(myInput As String) As String
56+
' Declaring variables
57+
Dim myResult As String ' This is the return string
58+
Dim i As Long ' Counter for character position
59+
60+
' Initialise return string to empty
61+
myResult = ""
62+
63+
' For every character in input string, copy digit to
64+
' return string if they are passing criteria
65+
For i = 1 To Len(myInput)
66+
If Mid(myInput, i, 1) >= "0" And Mid(myInput, i, 1) <= "9" Then
67+
myResult = myResult + Mid(myInput, i, 1)
68+
Exit For
69+
End If
70+
Next
71+
72+
' Then return the return string. '
73+
getOnlyDigit = myResult
74+
End Function
75+
'========================================
76+
' FUNCTION that tells if string contains digits
77+
'========================================
78+
' function is adapted using function getOnlyDigits
79+
Function isDigit(myInput As String) As Boolean
80+
' Variables needed (remember to use "option explicit")
81+
Dim myResult As Boolean ' This is the return boolean
82+
Dim i As Integer ' Counter for character position
83+
84+
' Initialise return result to be false
85+
myResult = False
86+
87+
' For every character in input string, check if there are
88+
' numbers. Stop if found at least one number
89+
For i = 1 To Len(myInput)
90+
If Mid(myInput, i, 1) >= "0" And Mid(myInput, i, 1) <= "9" Then
91+
myResult = True
92+
Exit For
93+
Else
94+
myResult = False
95+
End If
96+
Next
97+
98+
' Then return the results
99+
isDigit = myResult
100+
End Function
101+
'========================================
102+
' FUNCTION that count cell color in a range
103+
'========================================
104+
' This is a user defined function! UDF!
105+
Function CountCellColor(range_data As Range, criteria As Range) As Long
106+
Dim datax As Range
107+
Dim xcolor As Long
108+
xcolor = criteria.Interior.ColorIndex
109+
For Each datax In range_data
110+
If datax.Interior.ColorIndex = xcolor Then
111+
CountCcolor = CountCcolor + 1
112+
End If
113+
Next datax
114+
End Function

‎MyCarCheckListForm.frm

Lines changed: 213 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,213 @@
1+
VERSION 5.00
2+
Begin {C62A69F0-16DC-11CE-9E98-00AA00574A4F} MyCarCheckListForm
3+
Caption = "User Form for Car Evaluation"
4+
ClientHeight = 8520
5+
ClientLeft = 45
6+
ClientTop = 375
7+
ClientWidth = 10515
8+
OleObjectBlob = "MyCarCheckListForm.frx":0000
9+
StartUpPosition = 1 'CenterOwner
10+
End
11+
Attribute VB_Name = "MyCarCheckListForm"
12+
Attribute VB_GlobalNameSpace = False
13+
Attribute VB_Creatable = False
14+
Attribute VB_PredeclaredId = True
15+
Attribute VB_Exposed = False
16+
' (C) 2017 VZ Home Experiments Vladimir Zhbanko //[email protected]
17+
' VBA code to make work with Excel User Forms easier
18+
' More time to spend on more interesting stuff.
19+
' =======================================================================================================
20+
' declaring global variables for cross using in the other functions
21+
' =======================================================================================================
22+
Public Fail As String ' 2 types Yes/No
23+
Public picPath As String ' string is containing the path to the picture file
24+
Public lRow As Long ' variable to pass row information
25+
' =======================================================================================================
26+
' this button closes the form
27+
' =======================================================================================================
28+
Private Sub buttonCancel_Click()
29+
Unload Me
30+
End Sub
31+
' =======================================================================================================
32+
' information about the program shown by clicking on the button "I am inspired"
33+
' =======================================================================================================
34+
Private Sub buttonHelp_Click()
35+
MsgBox "User Form for Car Evaluation" & vbCrLf & "(C) 2017 VZ Home Experiments [email protected]", vbOKOnly + vbInformation, "I am inspired!"
36+
End Sub
37+
' =======================================================================================================
38+
' add Spin Buttons control
39+
' =======================================================================================================
40+
Private Sub SpinButton1_SpinUp()
41+
If Me.tboxRow.Value <= 2 Then
42+
Exit Sub
43+
End If
44+
Worksheets(Me.tboxSheet.Text).Activate
45+
UpdateInputs Me.tboxRow.Value - 1
46+
End Sub
47+
Private Sub SpinButton1_SpinDown()
48+
Worksheets(Me.tboxSheet.Text).Activate
49+
UpdateInputs Me.tboxRow.Value + 1
50+
End Sub
51+
52+
' =======================================================================================================
53+
' first form initialization bringing default values
54+
' =======================================================================================================
55+
Private Sub UserForm_Initialize()
56+
' Not used; code below will be executed on form initialization
57+
58+
End Sub
59+
' =======================================================================================================
60+
' User Dialogue "Import Picture"
61+
' =======================================================================================================
62+
' this portion should point to the picture to enter to the userform
63+
' user select picture browsing to the file and picture is grabbed inside the form
64+
' path to the picture will be stored into Public variable so
65+
' user will continue to write issue description and upon submitting picture is placed to the cell...
66+
' Button "Insert Picture"
67+
Private Sub buttonPicture_Click()
68+
69+
' File dialog to load picture into the form
70+
With Application.FileDialog(msoFileDialogFilePicker)
71+
.AllowMultiSelect = False
72+
.ButtonName = "Submit"
73+
.Title = "Select an image file"
74+
.Filters.Add "Image", "*.gif; *.jpg; *.jpeg", 1
75+
76+
If .Show = -1 Then
77+
'file has been selected
78+
picPath = .SelectedItems(1) ' this will save path to the picture!
79+
80+
'display preview image in image control
81+
Me.imageReport.PictureSizeMode = fmPictureSizeModeZoom
82+
Me.imageReport.Picture = LoadPicture(picPath)
83+
84+
Else
85+
' executed when nothing was selected
86+
87+
End If
88+
End With
89+
90+
' picture is now in the image box
91+
' path of the picture picPath is saved into Global variable
92+
93+
End Sub
94+
' =======================================================================================================
95+
' Copy to the Report page
96+
' =======================================================================================================
97+
' This code will copy form data from UserForm to the Report page
98+
' Also required to paste comment and score to the reference page if it was changed
99+
' Report page should increase it's size by one row automatically
100+
Private Sub buttonSubmit_Click()
101+
102+
Dim i As Integer: Dim lRow As Long: Dim lCol As Long: Dim nextRowValue As String
103+
Dim wshDest As Worksheet: Set wshDest = Worksheets("Report")
104+
Dim wshSource As Worksheet: Set wshSource = Worksheets(Me.tboxSheet.Text)
105+
106+
' =======================================
107+
' code below will check position of radio buttons
108+
' =======================================
109+
If (Me.optionYes.Value = True) Then
110+
Fail = "Yes"
111+
End If
112+
113+
If (Me.optionNo.Value = True) Then
114+
Fail = "No"
115+
End If
116+
117+
' Adding protection against incomplete entry - Case Study 1
118+
If (Me.optionYes.Value = False) And (Me.optionNo.Value = False) Then
119+
Me.optionNo.SetFocus
120+
MsgBox "Check must either pass or fail, please choose at least one option"
121+
Exit Sub
122+
End If
123+
124+
' =======================================
125+
' This portion refreshes the comment and the score on the source sheet
126+
' =======================================
127+
' refreshing data on the source sheet
128+
' define the source sheet
129+
' write the comment and score to the source sheet (it might be changed)
130+
wshSource.Cells(Me.tboxRow.Value, 6) = Fail 'score
131+
wshSource.Cells(Me.tboxRow.Value, 7) = Me.tboxComments.Value 'comment
132+
133+
' =======================================
134+
' below portion will handle updating the Action page from the UserForm
135+
' =======================================
136+
' only if cboxNeedAction is true
137+
If Me.cboxNeedAction.Value = False Then
138+
' exit sub if action is not needed
139+
MsgBox "Comment and Score are updated, No Action is created", vbOKOnly + vbInformation, "Source sheet is refreshed"
140+
Exit Sub
141+
142+
Else
143+
' =======================================
144+
' find the next empty row in the destination sheet
145+
' =======================================
146+
wshDest.Activate
147+
' method below will fill the next available empty row
148+
' lRow will contain the last written row (ready to write)
149+
For i = 1 To 2000 ' There can not be more than a 2000 rows really!?
150+
currentRowValue = Cells(i, 3).Value
151+
nextRowValue = Cells(i + 1, 1).Value ' saving content of the next rows to add rows dynamically
152+
153+
' find where is the last available row in the table
154+
If IsEmpty(currentRowValue) Or currentRowValue = "" Then
155+
lRow = i
156+
If isDigit(Cells(i - 1, 1).Value) = False Then ' if the cell is not number it is a header
157+
wshDest.Cells(i, 1).Value = 1 ' place the starting number
158+
Else
159+
wshDest.Cells(i, 1).Value = wshDest.Cells(i - 1, 1).Value + 1 ' place the consecutive number
160+
wshDest.Cells(i + 1, 1).Value = wshDest.Cells(i, 1).Value + 1 ' place the consecutive number
161+
End If
162+
Exit For
163+
End If
164+
165+
Next
166+
' =======================================
167+
' check for a completness of the form when gaps are identified
168+
' =======================================
169+
' logic behind: If Fail is 'Yes' then Comments and Actions are required!
170+
If (Me.optionYes.Value = True) And (Trim(Me.tboxComments.Value) = "") Then
171+
Me.tboxComments.SetFocus
172+
MsgBox "Please complete the Action and Comment fields of the form as gaps are identified"
173+
Exit Sub
174+
175+
End If
176+
177+
' =======================================
178+
' populate the Result sheet
179+
' =======================================
180+
wshDest.Cells(lRow, 3).Value = Me.tboxCategory.Value 'Category
181+
wshDest.Cells(lRow, 4).Interior.ColorIndex = Me.tboxKey.Value 'Key color
182+
wshDest.Cells(lRow, 5).Value = Me.tboxComments.Value 'Comments
183+
wshDest.Cells(lRow, 6).Value = Me.tboxAction.Value 'Action
184+
wshDest.Cells(lRow, 7).Value = Me.tboxCost.Value 'Cost
185+
wshDest.Cells(lRow, 8).Value = picPath 'Path of the picture
186+
187+
' Clear the data to be able to fill more again - Case Study 1
188+
Me.tboxComments.Value = ""
189+
Me.tboxAction.Value = ""
190+
Me.tboxCost.Value = ""
191+
Me.cboxNeedAction.Value = False
192+
Me.optionNo = False
193+
Me.optionYes = False
194+
195+
' Adding Budget field - Case Study 1
196+
Call UpdateBudget
197+
198+
End If
199+
200+
' =======================================
201+
' Code will paste picture to the Result sheet
202+
' =======================================
203+
' exit if there was no picture added
204+
If picPath = "" Then
205+
Exit Sub
206+
Else
207+
' add picture using function PastePicture (see module Functions)
208+
PastePicture picPath, lRow
209+
End If
210+
211+
End Sub
212+
213+
' =======================================================================================================

‎MyCarCheckListForm.frx

2.49 MB
Binary file not shown.

0 commit comments

Comments
 (0)