I have the following code to check values entered into two input boxes, if both values are zero then the MsgBox should display "Stop!" (I will change this later to exiting the sub but I am using a MsgBox for testing)
From testing I've seen these results:
A zero in both strings produces the expected message box.
A non zero in the first string followed by any non zero value in the second string does nothing (as expected).
A zero in the first string followed by a second string value equal to or greater than 10 produces the message box (unexpected).
I've also noticed that if the second string is 6-9 it is displayed as x.00000000000001%. I think this is a floating point issue and could be related? This behaviour occurs without the IF... InStr function too.
Option Explicit
Sub Models()
Dim MinPer As String, MaxPer As String, Frmula As String
Dim Data As Worksheet, Results As Worksheet
Set Data = Sheets("Data")
Set Results = Sheets("Results")
Application.ScreenUpdating = False
MinPer = 1 - InputBox("Enter Minimum Threshold Percentage, do not include the % symbol", _
"Minimum?") / 100
MaxPer = 1 + InputBox("Enter Maximum Threshold Percentage, do not include the % symbol", _
"Maximum?") / 100
If (InStr(MinPer, "0") = 0) And (InStr(MaxPer, "0") = 0) Then
MsgBox "STOP!"
End If
' Remainder of code...
This is the most interesting problem I've come across so far in VBA and welcome any discussion about it.
Edit: I use this code to display on screen the paramaters for the end-user to see. Hence how I noticed the .00000000001% issue:
.Range("D2").Value = "Min is " & 100 - MinPer * 100 & "%"
.Range("D3").Value = "Max is " & MaxPer * 100 - 100 & "%"
Two things
1) Declare MinPer, MaxPer as Long or a Double and not a String as you are storing outputs from a calculation
2) Don't directly use the InputBox in the calculations. Store them in a variable and then if the input is valid then use them in the calculation
Dim MinPer As Double, MaxPer As Double, Frmula As String
Dim Data As Worksheet, Results As Worksheet
Dim n1 As Long, n2 As Long
Set Data = Sheets("Data")
Set Results = Sheets("Results")
Application.ScreenUpdating = False
On Error Resume Next
n1 = Application.InputBox(Prompt:="Enter Minimum Threshold Percentage, do not include the % symbol", _
Title:="Minimum?", Type:=1)
On Error GoTo 0
If n1 = False Then
MsgBox "User cancelled"
Exit Sub
End If
On Error Resume Next
n2 = Application.InputBox(Prompt:="Enter Maximum Threshold Percentage, do not include the % symbol", _
Title:="Maximum?", Type:=1)
On Error GoTo 0
If n2 = False Then
MsgBox "User cancelled"
Exit Sub
End If
If n1 = 0 And n2 = 0 Then
MsgBox "STOP!"
End If
MinPer = 1 - (Val(n1) / 100)
MaxPer = 1 + (Val(n2) / 100)
This is because the number "10" has a "0" in the string (second character) so both evaluate to true.
Try this instead:
If (MinPer = "0") And (MaxPer = "0") Then
MsgBox "STOP!"
End If
For additional control save the user input (MinPer , MaxPer) and THEN text them for validity before performing nay mathematical operations on them.
InStr(MinPer, "0") is just checking to see whether the string contains a zero
character.
You need to convert the string value to an integer. Use the IsNumeric and CInt functions
to do that. See this URL:
vba convert string to int if string is a number
Dim minPerINT as Integer
Dim maxPerINT as Integer
If IsNumeric(minPer) Then
minPerINT = CInt(minPer)
Else
minPerINT = 0
End If
If IsNumeric(maxPer) Then
maxPerINT = CInt(maxPer)
Else
maxPerINT = 0
End If
If minPerINT = 0 and maxPerINT=0 Then
MsgBox "STOP!"
End If
Depending on what data can be entered It may also be a good idea to check if the length
of the data is zero using the len() function.
Related
I have this Sub. It is activated when pressing a button on a user form and is used to count one entry up. I have the total amount of entries in this data base stored in A1. There is another button used to count one entry down, it works just fine. They both have checks so they don't load entries that don't exist. Somehow this one doesn't work.
Private Sub ButtonRight_Click()
MsgBox TextBoxID.Value
MsgBox Cells(1, 1).Value
MsgBox (TextBoxID.Value < Cells(1, 1).Value)
If TextBoxID.Value < Cells(1, 1).Value Then
LoadEntry (TextBoxID.Value + 1)
End If
End Sub
The LoadEntry Sub is used in other places as well and it works. I have this output stuff with MsgBox for debugging. It gives the outputs 1, 2, false. So (1 < 2) = false.
For comparison here is the other one which works:
Private Sub ButtonLeft_Click()
If TextBoxID.Value > 1 Then
LoadEntry (TextBoxID.Value - 1)
End If
End Sub
The problem is implicit conversions.
Strings are compared as text, so "10" is smaller than "2" because it sorts alphabetically as such.
Debug.Print "10" > "2" ' output: False
The value of a TextBox control is always a String; in order to treat it as a numeric value you must first convert it to a numeric value - but only if it's legal to do so (e.g. "ABC" has no equivalent numeric value).
Moreover, a cell's value is a Variant that may contain a number or another value that can (will) correctly but implicitly convert to a numeric value, but it could also be a Variant/Error (e.g. #N/A, or #VALUE! errors) that will throw a type mismatch error every time you try to compare it to anything (other than another Variant/Error value), so the cell's value should also be validated and explicitly converted before it's compared:
Dim rawValue As String
rawValue = TextBoxID.Value
If IsNumeric(rawValue) Then
Dim numValue As Double
numValue = CDbl(rawValue)
Dim cellValue As Variant
cellValue = ActiveSheet.Cells(1, 1).Value
If IsNumeric(cellValue) Then
If numValue < CDbl(cellValue) Then
LoadEntry numValue + 1
End If
End If
End If
Note that unqualified, Cells is implicitly referring to whatever the ActiveSheet happens to be - if that isn't the intent, consider qualifying that member call with an explicit Worksheet object, e.g. Sheet1.Cells(1, 1). If it is intentional, consider qualifying it with ActiveSheet so that the code says what it does, and does what it says.
Comparing values of different types in VBA is not a simple task, the result of the comparison depends on the types of variables, the possibility of conversion to a number, etc. Variant variables are compared differently than "non-Variant" variables. See https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/comparison-operators
According to the documentation, the Value property of the TextBox object has a base type Variant (see https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/value-property-microsoft-forms).
Therefore, the result of comparing Variant/String (TextBox.Value with String) and Variant/Double (Cell.Value with number) - TextBox.Value is always larger than Cell.Value:
Private Sub CommandButton1_Click()
TextBox1.Value = "123"
[A1].Value = 9999
Debug.Print "TextBox1.Value = " & TextBox1.Value & ", Type is " & TypeName(TextBox1.Value)
Debug.Print "[A1].Value = " & [A1].Value & ", Type is "; TypeName([A1].Value)
Debug.Print "TextBox1.Value > [A1].Value : (" & TextBox1.Value & " > " & [A1].Value & ") is " & (TextBox1.Value > [A1].Value)
Me.Hide
End Sub
'Output:
'TextBox1.Value = 123, Type is String
'[A1].Value = 9999, Type is Double
'TextBox1.Value > [A1].Value : (123 > 9999) is True
Therefore, it is advisable before comparing:
reduce the types of compared values to one;
to handle errors of type conversion
Simple way is to use Val() function https://learn.microsoft.com/en-us/office/vba/language/reference/user-interface-help/val-function
Private Sub ButtonRight_Click()
If Val(TextBoxID.Value) < Val(Cells(1, 1).Value) Then
LoadEntry (TextBoxID.Value + 1)
End If
End Sub
Also for this purpose I propose to create a function:
Function getNumDef(v As Variant, Optional defV As Long = -1) As Long
getNumDef = defV 'inintially getNumDef set as defaul value
On Error Resume Next
getNumDef = CLng(v) ' if error occurs, getNumDef value remains defV
End Function
It can be applied in the following way:
Private Sub ButtonRight_Click()
Dim TBV as Long, CV as Long
TBV = getNumDef(TextBoxID.Value) 'Type conversion and error handling
CV = getNumDef(Cells(1, 1).Value) 'Type conversion and error handling
If TBV < 0 Or CV < 0 Then
MsgBox "Some of the values are not numeric or less than 0" _
& vbCrLf & "Check the raw data", vbCritical + vbOKOnly, "Sub ButtonRight_Click()"
Else
If TBV < CV Then
'The parentheses in `LoadEntry (TextBoxID.Value + 1)` are syntax sugar,
' i.e. the argument `TextBoxID.Value + 1` in parentheses is passed as ByVal.
'If the argument without (), i.e. `LoadEntry TextBoxID.Value + 1`,
'it is passed as described in the Sub definition or the default ByRef
LoadEntry TextBoxID.Value + 1
End If
End If
End Sub
I am trying to grab a cell check if it has decimal places and remove them then place a specific format in a cell depending on how many characters there are in the number, the len function returns null, and the instr function works but when passed to a variable returns null. Thank you to anyone who can help. At the end of the first if function I print the results of the 3 variables not working to the immediate window to verify, with the Debug.Print command please go to view menu and activate immediate window to watch.
Function cnvtDta()
ActiveSheet.Select
Data1 = Range("data").Value
Dim rslt As String
rslt = Data1
Set myrng = Range("data")
Dim wot, sowot
'Find decimal place in cell
dot = myrng.Find(".", myrng)
If dot = True Then
'if decimal place strip remainders and decimal point
Dim pos, res
pos = InStr(1, rslt, ".")
res = Left(rslt, pos)
sowot = Len(res)
End If
Debug.Print res
Debug.Print sowot
Debug.Print pos
'Return specific formats to cell
'thank you kindly to anyone who can spare the time to genuinely help
End Function
So basically there's a couple of parts to your question.
Check if value has decimals. Here's one way to do it (based on values, not on strings)
Function DoesCellContainDecimals(inputRange As Range) As Boolean
Dim tolerance As Double
tolerance = 0.0001
If Not IsNumeric(inputRange.Value2) Then
'invalid argument
DoesCellContainDecimals = False
Exit Function
End If
If (Abs(Fix(inputRange.Value2) - inputRange.Value2) < tolerance) Then
'value does not have meaningful decimals
DoesCellContainDecimals = False
Else
'value has meaningful decimals
DoesCellContainDecimals = True
End If
End Function
Get the integer part of a number. There are two functions. Similar but different behavior with negative numbers (make sure if the value is a number first):
Int(6.5) '6
Fix(6.5) '6
Int(-6.5) '-7
Fix(-6.5) '-6
Format a number. Either turn it to string or set Range.NumberFormat property:
Format(6500000,"# ### ###") '6 500 000
Range("A1").NumberFormat = "# ### ##0" 'same effect as above but only when displaying in that cell.
I need to round time to the nearest quarter hour in a word document. I am not very good at coding.
After a fair bit of searching I have found some vba code but it doesn't quite work. The code is:
Sub Time()
Dim num() As String
Dim tod() As String
Dim temp As String
num = Split(Time, ":")
tod = Split(num(2), " ")
If Val(num(1)) < 15 Then
temp = "00"
ElseIf Val(num(1)) < 30 Then
temp = "15"
ElseIf Val(num(1)) < 45 Then
temp = "30"
ElseIf Val(num(1)) < 60 Then
temp = "45"
End If
gettime = num(0) + ":" + temp + ":00 " + tod(1)
End Function
End Sub
When I try to run it I get a message:
"Compile Error: Expected function or variable"
and "Time" on the fifth line of the code is highlighted which I think is where the program stops running.
The rest of the code in the form is as follows:
This module doesn't affect the time rounding issue but I am including it so as not to leave anything out.
Option Explicit
Sub ClusterCheck()
Dim i As Integer, k As Integer, iCluster As Integer, bResult As Boolean
Dim sFieldNameNo As String, sName As String
On Error Resume Next ' If the first formfield is a checkbox, this will bypass the error that Word returns
sName = Selection.FormFields(1).Name ' Get the name of the formfield
bResult = ActiveDocument.FormFields(sName).CheckBox.Value ' Get the result of the current formfield
sFieldNameNo = Number(sName) ' Get generic number
sName = Left(sName, Len(sName) - Len(sFieldNameNo)) ' Get generic name
' Determine how many fields are within the cluster group
iCluster = 1
Do Until ActiveDocument.Bookmarks.Exists(sName & iCluster) = False
iCluster = iCluster + 1
Loop
iCluster = iCluster - 1
' If the check field is true, turn all of the other check fields to false
Application.ScreenUpdating = False
If bResult = True Then
For k = 1 To iCluster
If k <> sFieldNameNo Then ActiveDocument.FormFields(sName & k).Result = False
Next
End If
Application.ScreenUpdating = True
End Sub
This is the Number module:
Option Explicit
Function Number(ByVal sNumber As String) As String
' This module finds the form fields number within the field name
' Loops through the field name until it only has the number
Do Until IsNumeric(sNumber) = True Or sNumber = ""
sNumber = Right(sNumber, Len(sNumber) - 1)
Loop
Number = sNumber
End Function
This is the protection module:
Option Explicit
Sub Protect()
ActiveDocument.Protect Password:="wup13", NoReset:=True, Type:=wdAllowOnlyFormFields
End Sub
Sub Unprotect()
ActiveDocument.Unprotect Password:="wup13"
End Sub
This is the code that activates on opening and closing the document:
Option Explicit
Sub Document_Open()
' Zooms to page width, turns on Hidden Text, and turns off ShowAll and Table Gridlines
With ActiveWindow.View
.Zoom.PageFit = wdPageFitBestFit
.ShowHiddenText = True
.TableGridlines = False
.ShowAll = False
End With
Options.UpdateFieldsAtPrint = False
End Sub
Sub Document_Close()
' Turn on ShowAll and Table Gridlines
With ActiveWindow.View
.ShowAll = True
.TableGridlines = True
End With
Options.UpdateFieldsAtPrint = True
End Sub
That's all the code in the form. I am not great at VBA but am hoping I can solve this issue (with a little help).
DETAILS OF EXTRA DUTY FORM
Persons details
Family name:
Given name(s):
Level:
No.:
Location:
Cost Centre Code:
Time worked
Were any days of the extra duty performed on a designated public/show holiday? Yes 0 No 0
If yes enter holiday date/details:
Time commenced: [Text Form Field]
Date:
Time ceased: [Text Form Field]
Date:
Total Overtime claimed:
Are you a shift worker? Yes 0 No 0
Details of extra duty performed:
Vehicle details
Car: Yes 0 No 0
Motorcycle: Yes 0 No 0
Registration no.:
Fleet no.:
Stationary vehicle hours:
Yes 0 No 0 (only use for stationary duties)
Vehicle odometer start:
Odometer finish:
Total kms:
Client’s details
Company/Organisation name:
Phone no.:
Contact name:
Job no.:
Payment for special services
Was payment received in advance? Yes 0 No 0
If Yes– Amount:
Receipt no.:
Date:
If No– Amount:
Invoice no.:
Date:
I, , certify the above information to be true
(Signature) (Date)
Manager certification (Checked with roster and certified correct)
(Signature) (Date)
The code from vbforums gives me a subscript out of range error when used as recommended.
In the VBA IDE you can get explanations of what keywords do by placing the cursor on a keyword and pressing F1. This will bring up the MS help page for that particular keyword.
In the OP code the main procedure is 'Time'. This will cause problems for VBA because this is the same as the Time keyword so we would effectively be saying
time(time)
and VBA will stop with an error because the second use of time will be interpreted as the sub time and not the VBA time function so you will get the error message 'Argument not optional'.
The code below will provide what the OP has requested.
Option Explicit
Sub test_gettime()
Dim myTime As String
myTime = Now()
Debug.Print myTime
Debug.Print Format(myTime, "hh:mm:ss")
Debug.Print gettime(Format(myTime, "hh:mm:ss"))
' without the format statement we should also get the date
myTime = Now()
Debug.Print
Debug.Print myTime
Debug.Print gettime(myTime)
End Sub
Public Function gettime(this_time As String) As String
Dim myTimeArray() As String
Dim myQuarterHour As String
myTimeArray = Split(this_time, ":")
' Note that myTimeArray has not been converted to numbers
' Comparison of strings works by comparing the ascii values of each character
' in turn until the requested logic is satisfied
Select Case myTimeArray(1)
Case Is < "15"
myQuarterHour = "00"
Case Is < "30"
myQuarterHour = "15"
Case Is < "45"
myQuarterHour = "30"
Case Is < "60"
myQuarterHour = "45"
Case Else
Debug.Print "More than 60 minutes in the hour??"
End Select
gettime = myTimeArray(0) + ":" + myQuarterHour + ":00 "
End Function
I need to validate user input on when cells change and show the error in another cell in Excel using VBA.
I run into problems where my validator is called on all cells in the sheet when a user inserts rows or column which makes Excel unresponsive for a long time, how can I fix this?
Below are my requirements and my current solution with full documentation.
Definition and requirements
Consider the following table:
Example User Input Table
| | | Tolerance | | |
| Type | Length | enabled | Tolerance | Note |
|------|--------|-----------|-----------|----------------------------|
| | 4 | 0 | | Type is missing |
| | | 0 | | Type is missing |
| C | 40 | 1 | 110 | |
| D | 50 | 1 | | Tolerance is missing |
| | | | | |
The idea is that the user inputs values in the table, once a value has been changed (the user leaves the cell) the value is validated and if there is a problem the error is printed in the Note column.
Blank lines should be ignored.
I need this to be robust meaning it should not fail on any user input, that means it has to work for the following cases:
Paste values
Delete rows
Insert rows (empty or cut cells)
Insert/delete columns *
Any other case I missed thinking about?
*It is OK if the the validation fails when a user is deleting a column that is part of the table as this is seen as the user willfully vandalizing the sheet, but it has to fail gracefully (i.e. not by validating all cells in the worksheet which takes a long time). It would have been great if this action was undoable, however my current understanding of Excel suggests this is impossible (after a macro has changed something in the sheet, nothing can be undone anymore).
The Note cell can only contain one error at a time, for the user the most relevant error is the one for the cell the user last changed, so it should display this error first. After the user fixes that error the order is not that important anymore, so it could just display the errors from left to right.
Problems with current approach
My problem is that when rows/columns are inserted validation is triggered for all cells in the sheet which is a very slow process and to the user it looks like the program has crashed, but it will return once the validation is complete.
I don't know why Excel does this but I need a way to work around it.
Code placed in a Sheet named 'User Input'
My solution is based on the only on change event handler I know of: the per sheet global Worksheet_Change function (ugh!).
Worksheet_Change function
First it checks if the changed cell(s) intersects with the cells I'm interested in validating. This check is actually quite fast.
OldRowCount here is a try to catch the user inserting or deleting cells depending on how the used range changes, however this only solves some cases and introduces problems whenever Excel forgets the global variable (which happens now and then for as to me unknown reasons) as well as the first time the function is run.
The for loop makes it work for pasted values.
Option Explicit
Public OldRowCount As Long
' Run every time something is changed in the User Input sheet, it then filters on actions in the table
Private Sub Worksheet_Change(ByVal Target As Range)
Dim NewRowCount As Long
NewRowCount = ActiveSheet.UsedRange.Rows.count
If OldRowCount = NewRowCount Then
If Not Intersect(Target, Me.Range(COL_TYPE & ":" & COL_TOLERANCE)) Is Nothing Then
Dim myCell As Range
' This loop makes it work if multiple cells are changed, for example while pasting cells
For Each myCell In Target.Cells
' Protect the header rows
If myCell.row >= ROW_FIRST Then
checkInput_cell myCell.row, myCell.Column, Me
End If
Next
End If
ElseIf OldRowCount > NewRowCount Then
'Row deleted, won't have to deal with this as it solves itself
OldRowCount = NewRowCount
ElseIf OldRowCount < NewRowCount Then
Debug.Print "Row added, TODO: deal with this"
OldRowCount = NewRowCount
End If
End Sub
Code placed in a module
Global variables
Defines the rows/columns to be validated.
Option Explicit
' User input sheet set up
Public Const ROW_FIRST = 8
Public Const COL_TYPE = "B"
Public Const COL_LENGTH = "C"
Public Const COL_TOLERANCE_ENABLED = "D"
Public Const COL_TOLERANCE = "E"
Public Const COL_NOTE = "G"
Cell checking function
This function validates the given cell unless the row where the cell is is empty.
Meaning we are only interested in validating cells on rows where the user has actually started giving values. Blank rows is not a problem.
It first validates the currently changed cell, if it is OK it will then validate the other cells on the given row (since some cells validation depends the values of other cells, see Tolerance enabled in my example table above).
The note will only ever contain one error message at a time, the above is done so that we always get the error of the last changed cell in the Note cell.
Yes, this will make the checker run twice on the current cell, while it is not a problem it could be avoided by a more complex if statement, but for simplicity I skipped it.
Sub checkInput_cell(thisRow As Long, thisCol As Long, sheet As Worksheet)
Dim note As String
note = ""
With sheet
' Ignore blank lines
If .Range(COL_TYPE & thisRow).value <> "" _
Or .Range(COL_LENGTH & thisRow).value <> "" _
Or .Range(COL_TOLERANCE_ENABLED & thisRow).value <> "" _
Or .Range(COL_TOLERANCE & thisRow).value <> "" _
Then
' First check the column the user changed
If col2Let(thisCol) = COL_TYPE Then
note = check_type(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_LENGTH Then
note = check_length(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_TOLERANCE_ENABLED Then
note = check_tolerance_enabled(thisRow, sheet)
ElseIf col2Let(thisCol) = COL_TOLERANCE Then
note = check_tolerance(thisRow, sheet)
End If
' If that did not result in an error, check the others
If note = "" Then note = check_type(thisRow, sheet)
If note = "" Then note = check_length(thisRow, sheet)
If note = "" Then note = check_tolerance_enabled(thisRow, sheet)
If note = "" Then note = check_tolerance(thisRow, sheet)
End If
' Set note string (done outside the if blank lines checker so that it will reset the note to nothing on blank lines)
' only change it actually set it if it has changed (optimization)
If Not .Range(COL_NOTE & thisRow).value = note Then
.Range(COL_NOTE & thisRow).value = note
End If
End With
End Sub
Validators for individual columns
These functions takes a row and validate the a certain column according to it's special requirements. Returns a string if the validation fails.
' Makes sure that type is :
' Unique in its column
' Not empty
Function check_type(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
Dim duplicate_found As Boolean
Dim lastRow As Long
Dim i As Long
duplicate_found = False
value = sheet.Range(COL_TYPE & affectedRow).value
check_type = ""
' Empty value check
If value = "" Then
check_type = "Type is missing"
Else
' Check for uniqueness
lastRow = sheet.Range(COL_TYPE & sheet.Rows.count).End(xlUp).row
If lastRow > ROW_FIRST Then
For i = ROW_FIRST To lastRow
If Not i = affectedRow And sheet.Range(COL_TYPE & i).value = value Then
duplicate_found = True
End If
Next
End If
If duplicate_found Then
check_type = "Type has to be unique"
Else
' OK
End If
End If
End Function
' Makes sure that length is a whole number larger than -1
Function check_length(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_LENGTH & affectedRow).value
check_length = ""
If value = "" Then
check_length = "Length is missing"
ElseIf IsNumeric(value) Then
If Not Int(value) = value Then
check_length = "Length cannot be decimal"
ElseIf value < 0 Then
check_length = "Length is below 0"
ElseIf InStr(1, value, ".") > 0 Then
check_length = "Length contains a dot"
Else
' OK
End If
ElseIf Not IsNumeric(value) Then
check_length = "Length is not a number"
End If
End Function
' Makes sure that tolerance enabled is either 1 or 0:
Function check_tolerance_enabled(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_TOLERANCE_ENABLED & affectedRow).value
check_tolerance_enabled = ""
If Not value = "0" And Not value = "1" Then
check_tolerance_enabled = "Tolerance enabled has to be 1 or 0"
Else
' OK
End If
End Function
' Makes sure that tolerance is a whole number larger than -1
' But only checks tolerance if it is enabled in the tolerance enabled column
Function check_tolerance(affectedRow As Long, sheet As Worksheet) As String
Dim value As String
value = sheet.Range(COL_TOLERANCE & affectedRow).value
check_tolerance = ""
If value = "" Then
If sheet.Range(COL_TOLERANCE_ENABLED & affectedRow).value = 1 Then
check_tolerance = "Tolerance is missing"
End If
ElseIf IsNumeric(value) Then
If Not Int(value) = value Then
check_tolerance = "Tolerance cannot be decimal"
ElseIf value < 0 Then
check_tolerance = "Tolerance is below 0"
ElseIf InStr(1, value, ".") > 0 Then
check_tolerance = "Tolerance contains a dot"
Else
' OK
End If
ElseIf Not IsNumeric(value) Then
check_tolerance = "Tolerance is not a number"
End If
End Function
Addressing support functions
These functions translates a letter to a column and vice versa.
Function let2Col(colStr As String) As Long
let2Col = Range(colStr & 1).Column
End Function
Function col2Let(iCol As Long) As String
Dim iAlpha As Long
Dim iRemainder As Long
iAlpha = Int(iCol / 27)
iRemainder = iCol - (iAlpha * 26)
If iAlpha > 0 Then
col2Let = Chr(iAlpha + 64)
End If
If iRemainder > 0 Then
col2Let = col2Let & Chr(iRemainder + 64)
End If
End Function
Code is tested on/has to work for Excel 2010 and onwards.
Edited for clarity
Finally got it working
After quite a bit of more agonizing, it turned out the fix was quite easy.
I added a new test that checks if the area that the user changed (the Target Range) consists of a column by looking at the address of the Range, if it is a full column the checker will ignore it. This solves the problem where the validation hogs Excel for about one minute.
The result of the intersection calculation is used for the inner loop which limits checks to cells within the area we are interested in validating.
Fixed Worksheet_Change function
Option Explicit
' Run every time something is changed in the User Input sheet
Private Sub Worksheet_Change(ByVal Target As Range)
Dim InterestingRange As Range
Set InterestingRange = Intersect(Target, Me.Range(COL_TYPE & ":" & COL_TOLERANCE))
If Not InterestingRange Is Nothing Then
' Guard against validating every cell in an inserted column
If Not RangeAddressRepresentsColumn(InterestingRange.address) Then
Dim myCell As Range
' This loop makes it work if multiple cells are changed,
' for example when pasting cells
For Each myCell In InterestingRange.Cells
' Protect the header rows
If myCell.row >= ROW_FIRST Then
checkInput_cell myCell.row, myCell.Column, Me
End If
Next
End If
End If
End Sub
New support function
' Takes an address string as input and determines if it represents a full column
' A full column is on the form $A:$A for single or $A:$C for multiple columns
' The unique characteristic of a column address is that it has always two
' dollar signs and one colon
Public Function RangeAddressRepresentsColumn(address As String) As Integer
Dim dollarSignCount As Integer
Dim hasColon As Boolean
Dim Counter As Integer
hasColon = False
dollarSignCount = 0
' Loop through each character in the string
For Counter = 1 To Len(address)
If Mid(address, Counter, 1) = "$" Then
dollarSignCount = dollarSignCount + 1
ElseIf Mid(address, Counter, 1) = ":" Then
hasColon = True
End If
Next
If hasColon And dollarSignCount = 2 Then
RangeAddressRepresentsColumn = True
Else
RangeAddressRepresentsColumn = False
End If
End Function
I am new to VBA and I'm trying to create a macro that from a inputBox accepts a number between 0 and 1000 and converts it to hexadecimal. Well it works, but I am struggling to keep the program accepting that range ( 0 - 1000). This is what happens:
If I input -1 it throws a error;
If I input -1001 it throws a FFFFFFFC17;
If I input any value above 1000 it doesn't throw a MsgBox (I am not familiar with causing error on excel for now).
I've done first like this:
Sub DecToHex()
Dim inputDec As Integer
Dim outputHex As String
inputDec = InputBox("Decimal?")
If inputDec <= 1000 And inputDec >= 0 Then
outputHex = Application.WorksheetFunction.Dec2Hex(inputDec)
MsgBox ("Hex: " + outputHex)
Else
MsgBox ("Error! Please define decimal. It must be larger than zero and less than 1001")
inputDec = InputBox("Decimal?")
outputHex = Application.WorksheetFunction.Dec2Hex(inputDec)
MsgBox ("Hex: " + outputHex)
End If
End Sub
But then I thought well inputBox gives me input as string, so maybe I should accept values as string, so I changed:
Dim inputDec As Integer
'Changed to
Dim inputDec As String
Which still did a poorly control on variables ( ie. it accepts -1200, as also 1200 ). So can you point out what am I doing wrong? Maybe it's the Worksheet Function I'm not reading well. I know it's newbie mistake but it's important for me to understand how to control these input variables from inputBox.
You need to declare the inputDec As Variant
You need to Handle the Cancel Button
You need to put the code in a loop so that when user enters an invalid number, the inputbox can pop up again.
You need to use Application.InputBox with Type:=1 so that only numbers can be accepted.
Try this
Sub DecToHex()
Dim inputDec As Variant
Dim outputHex As String
Do
inputDec = Application.InputBox("Decimal?", Type:=1)
'~~> Handle Cancel
If inputDec = "False" Then Exit Do
If inputDec <= 1000 And inputDec >= 0 Then
outputHex = Application.WorksheetFunction.Dec2Hex(inputDec)
MsgBox ("Hex: " + outputHex)
Exit Do '<~~ Exit the loop
Else
MsgBox ("Error! Please define decimal. It must be larger than zero and less than 1001")
End If
Loop
End Sub