Skip to content

Commit a7399df

Browse files
vzhomeexperimentsvzhomeexperiments
authored
Add files via upload
1 parent a13de03 commit a7399df

9 files changed

+821
-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+

‎2_InvokeUF_R.txt

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

‎CheckList_CaseStudy3.xlsm

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

‎MyCarCheckListForm.frx

2.49 MB
Binary file not shown.

0 commit comments

Comments
 (0)