Setting validation for combo box error - vba

#
updated codes
Function condition(ByRef objCmb As ComboBox)
If objCmb.Value ="" And objCmb.Value = "g" Then
Call MsgBox("gg", vbOKOnly, "error")
End If
End Function
Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition (ComboBox1)
End Sub
'other codes for reference:
Private Sub CommandButton1_Click()
Dim lastrow As Integer
lastrow = Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To 3
For j = 1 To 5
With Me.Controls("ComboBox" & (i - 1) * 5 + j)
If .Text <> "" Then
Cells(lastrow + i, j) = .Text
Else
Exit Sub
End If
End With
Next j
Next i
End Sub
I have 50 combo and text boxes in VBA user panel. As it is too troublesome to set constraints in every combo or text box, I want a function to apply to every combo and text box.
For the codes above , it shows up cant find objecterror
How to solve ?
Btw , how to set the function statement for textbox ?
is it Function condition2(ByRef objCmb As textbox)...

You are receiving an error because ComboBox is not ByRef objCmb As ComboBox. Don't use parenthesis when calling a sub. Don't use parenthesis when calling function if you are not using the functions return value. If a function does not return a value it should be a sub.
Sub condition(ByRef objCmb As MSForms.ComboBox)
If objCmb.Value <> "" And objCmb.Value = "g" Then
MsgBox "gg", vbOKOnly, "error"
objCmb.Value = ""
End If
End Sub
Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
I wrote a function to help you generate the Exit event code for all your text and combo boxes.
Sub AddCodeToCipBoard(frm As UserForm)
Const BaseCode = " Private Sub #Ctrl_Exit(ByVal Cancel As MSForms.ReturnBoolean)" & vbCrLf & _
" condition ComboBox1" & vbCrLf & _
" End Sub" & vbCrLf & vbCrLf
Dim s As String
Dim ctrl
Dim clip As DataObject
Set clip = New DataObject
For Each ctrl In frm.Controls
If TypeName(ctrl) = "ComboBox" Or TypeName(ctrl) = "TextBox" Then
s = s & Replace(BaseCode, "#Ctrl", ctrl.Name)
End If
Next
clip.SetText s
clip.PutInClipboard
End Sub
Put this code in a module and call it like this:
AddCodeToCipBoard Userform1
Now all the Exit event code will be copied into the Windows Clipboard. Go into your Userforms code module and paste the new code.
Example Output:
Private Sub TextBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
Private Sub TextBox2_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
Private Sub TextBox3_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
Private Sub ComboBox1_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub
Private Sub TextBox4_Exit(ByVal Cancel As MSForms.ReturnBoolean)
condition ComboBox1
End Sub

Related

Made null textbox and set focus on another

I'm using code below, for check another textbox value when exiting initial textbox and if it null, making initial one null and set focus on final textbox.
But i give this error: Run-time error'-2147467259(80004005)': Unspecific error.
when i made comment this line (txtTimeUnit = vbNullString), macro code works correctly.
whats the problem of that line's command and please help me correcting code.
Private Sub txtTimeUnit_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If txtStartDate.Text = vbNullString Then
txtTimeUnit = vbNullString
txtStartDate.SetFocus
Exit Sub
End If
End Sub
Like I said your code works. Here is an example
Private Sub txtTimeUnit_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If txtStartDate.Text = vbNullString Then
txtTimeUnit.Text = vbNullString
txtStartDate.SetFocus
Exit Sub
End If
End Sub
The only way it will not work is when there is another piece of code which is setting the Cancel = True. For example
Private Sub txtTimeUnit_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If IsError(Application.Match(txtTimeUnit.Text, Range("intTable[Time Unit]"), 0)) Then
Cancel = True
End If
If txtStartDate.Text = vbNullString Then
txtTimeUnit.Text = vbNullString
txtStartDate.SetFocus
Exit Sub
End If
End Sub
To prevent such kind of errors you can use a Boolean Variable
Dim boolOnce As Boolean
Private Sub txtTimeUnit_Exit(ByVal Cancel As MSForms.ReturnBoolean)
If boolOnce = False Then
boolOnce = True
If IsError(Application.Match(txtTimeUnit.Text, Range("intTable[Time Unit]"), 0)) Then
Cancel = True
End If
Else
boolOnce = False
End If
If txtStartDate.Text = vbNullString Then
txtTimeUnit.Text = vbNullString
txtStartDate.SetFocus
Exit Sub
End If
End Sub

VBA 2 IF conditions applied for column

this is my first post, please be patient if I'm doing/asking something wrong.
My issue is:
I got 2 columns, A is number of children, B is name of those children.
Those values are manually entered, I simply would like to have B mandatory if A is filled.
Here is what I thought:
Private Sub Workbook_BeforeClose(Cancel As Boolean)
If Not IsEmpty(Sheet1.Range("A1")) Then
If IsEmpty(Sheet1.Range("B1")) Then
MsgBox "Please fill in cell B1 before closing."
Cancel = True
Else '
End If
End If
End Sub
This is actually working perfectly, unfortunately I can't manage to extend it for whole columns, when replacing A1 with A1:A1000 and B1 with B1:B1000 for instance,it doesn't work.
How can I validate this for both entire column A and B?
thanks in advance!
Try this
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Cancel = Evaluate("SUMPRODUCT(--(ISBLANK(Sheet1!B:B) <> ISBLANK(Sheet1!A:A)))")
If Cancel Then MsgBox "Please fill in column B before closing."
End Sub
EDIT
In order to take the user to the place where data is missing, and taking into account the additional information you provided about your data, try this:
'Private Sub Workbook_BeforeClose(Cancel As Boolean)
Private Sub Workbook_BeforeSave(ByVal SaveAsUI As Boolean, Cancel As Boolean)
Dim r: r = Evaluate( _
"MATCH(FALSE, ISBLANK('ELENCO AGGIORNATO'!V:V) = ISBLANK('ELENCO AGGIORNATO'!W:W), 0)")
If IsError(r) Then Exit Sub ' All is fine
Cancel = True
Application.Goto Sheets("ELENCO AGGIORNATO").Cells(r, "V").Resize(, 2)
msgBox "Please fill missing data before saving."
End Sub
Also note that I recommend Workbook_BeforeSave instead of Workbook_BeforeClose, because there's no harm if the user decides to drop his (incomplete) work and close the workbook without saving.
You may try something like this...
Private Sub Workbook_BeforeClose(Cancel As Boolean)
Dim str As String
Dim Rng As Range, Cell As Range
Dim FoundBlank As Boolean
Set Rng = Sheet1.Range("A1:A1000")
str = "Please fill the cells listed below before colsing..." & vbNewLine & vbNewLine
For Each Cell In Rng
If Cell <> "" And Cell.Offset(0, 1) = "" Then
FoundBlank = True
str = str & Cell.Address(0, 1) & vbNewLine
End If
Next Cell
If FoundBlank Then
Cancel = True
MsgBox str, vbExclamation, "List of Blank Cells Found!"
End If
End Sub

(Excel VBA) How to Show AutoComplete Feature of a ComboBox as a DropDown List

I would like the following code to add values to a combobox, then when the user inputs characters into the combobox, the dropdown feature of the combobox will show only those items which contain those characters, similarly to the way the Google Search Bar works.
(source: intersites.com)
Code Edit:
Option Explicit
Option Compare Text
Public LC As Long
Public Count As Integer
Dim ComboArray() As String
'Initializes the userform, and saves values from database into an array
Private Sub UserForm_Initialize()
LC = Cells(1, Columns.Count).End(xlToLeft).Column
ReDim ComboArray(1 To LC)
For Count = 1 To LC
ComboArray(Count) = Cells(1, Count).Value
Next Count
End Sub
'Prevents changes if the down key is pressed?
Private Sub ComboBox_SiteName_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Application.ScreenUpdating = False
End Sub
'Adds values to combobox if they contain the string input by user
Private Sub ComboBox1_Change()
Dim pos As Integer
Dim i As Integer
ComboBox1.Clear
For Count = 1 To LC
pos = InStr(1, ComboArray(Count), ComboBox1.Value)
If pos <> 0 Then
With ComboBox1
.AddItem Cells(1, Count)
End With
End If
Next Count
End Sub
Here is a simple example, which may need refinement for your purposes, but illustrates the general principles of using the KeyPress event to build a string of user input, and compare that to each item in the list, effectively filtering the list to values that start with the input string.
This needs some refinement to handle backspacing, deleting, etc., which I tried to do, but didn't get as far as I'd like.
Code:
Option Explicit
Dim cbList As Variant
Dim userInput$
'### USERFORM EVENTS
Private Sub ComboBox1_KeyDown(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Select Case KeyCode
Case 8, 48
'MsgBox "Backspace"
Debug.Print "Backspace"
If userInput <> "" Then
userInput = Left(userInput, Len(userInput) - 1)
End If
Case 46
'MsgBox "Delete"
Debug.Print "Delete"
userInput = Replace(userInput, ComboBox1.SelText, "")
End Select
End Sub
Private Sub UserForm_Activate()
Dim cl As Range
userInput = ""
For Each cl In Range("A1:A8")
Me.ComboBox1.AddItem cl.Value
Next
Me.ComboBox1.MatchRequired = False
cbList = Me.ComboBox1.List
End Sub
Private Sub UserForm_Terminate()
userInput = ""
End Sub
'#### END USERFORM EVENTS
'#### COMBOBOX EVENTS
Private Sub ComboBox1_KeyPress(ByVal KeyAscii As MSForms.ReturnInteger)
Me.ComboBox1.List = cbList
' Capture the user input in module variable
userInput = userInput & Chr(KeyAscii)
Debug.Print "input: " & userInput
Debug.Print KeyAscii
Dim i As Long, itm
For i = Me.ComboBox1.ListCount - 1 To 0 Step -1
itm = Me.ComboBox1.List(i)
If Not StartsWith(CStr(itm), userInput) Then
Me.ComboBox1.RemoveItem i
End If
Next
If Me.ComboBox1.ListCount = 0 Then
Me.ComboBox1.List = cbList
Else
Me.ComboBox1.List = Me.ComboBox1.List
End If
Me.ComboBox1.DropDown
End Sub
'#### END COMBOBOX EVENTS
'#### HELPER FUNCTIONS
Function StartsWith(imtVal$, inputStr$, Optional caseSensitive As Boolean = False)
', Optional caseSensitive As Boolean = False
'If Not caseSensitive Then
imtVal = LCase(imtVal)
inputStr = LCase(inputStr)
'End If
StartsWith = VBA.Strings.Left(imtVal, Len(inputStr)) = inputStr
End Function
'#### END HELPER FUNCTIONS

Same macro for multiple textboxes on the same userform excel vba

I am currently making an userform in which I got multiple textboxes. So for now I got a total of 15 textboxes and each of them should only contain numerical values. The code I got now for each TextBox is:
Private Sub TextBox1_Change()
If TypeName(Me.ActiveControl) = "TextBox" Then
With Me.ActiveControl
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Sorry, only numbers allowed"
.Value = vbNullString
End If
End With
End If
End Sub
Private Sub TextBox2_Change()
If TypeName(Me.ActiveControl) = "TextBox" Then
With Me.ActiveControl
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Sorry, only numbers allowed"
.Value = vbNullString
End If
End With
End If
End Sub
.
.
.
Private Sub TextBox15_Change()
If TypeName(Me.ActiveControl) = "TextBox" Then
With Me.ActiveControl
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Sorry, only numbers allowed"
.Value = vbNullString
End If
End With
End If
End Sub
The way I am doing it now feels kind of sloppy since I am copying the same code for each textbox. My question is therefor whether it is possible to consolidate these routines so that I will only require one code for all off the TextBoxes?
Kind regards and thanks in advance,
Maurice
Simple example:
Add a new class module to your project and rename it NumericTextbox. Paste this code into it:
Option Explicit
Private WithEvents tb As MSForms.TextBox
Public Property Set TextControl(t As MSForms.TextBox)
Set tb = t
End Property
Private Sub tb_Change()
With tb
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Sorry, only numbers allowed"
.Value = vbNullString
End If
End With
End Sub
Now in your userform, add this code:
Option Explicit
Private colTBs As Collection
Private Sub UserForm_Initialize()
Dim ctl As MSForms.Control
Dim oHandler As NumericTextbox
Set colTBs = New Collection
For Each ctl In Me.Controls
If TypeOf ctl Is MSForms.TextBox Then
Set oHandler = New NumericTextbox
Set oHandler.TextControl = ctl
colTBs.Add oHandler
End If
Next ctl
End Sub
and there you go.
I just passed the textbox as an argument into my function as follows:
sheet code
Private Sub TextBox1_Change()
test Me.TextBox1
End Sub
Private Sub TextBox2_Change()
test Me.TextBox2
End Sub
Module code:
Sub test(textbox As Object)
With textbox
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Sorry, only numbers allowed"
.Value = vbNullString
End If
End With
End Sub
The easy way would be to have a handler for each of the text boxes so that a particular procedure follows each individual action, I would suggest separating your procedure as the following
Private Sub checkValue()
With Me.ActiveControl
If Not IsNumeric(.Value) And .Value <> vbNullString Then
MsgBox "Sorry, only numbers allowed"
.Value = vbNullString
End If
End With
End Sub
`Then call that sub from each of the textbox_change() procedures

How can i call a Sub using hyperlinks

I am newbie to VBA; I have a question:
How can I call sub to delete a cell in a sheet by using a Hyperlinks from another sheet.
A structure of the code is greatly appreciated.
Event handler in worksheet which contains the hyperlink:
Private Sub Worksheet_FollowHyperlink(ByVal Target As Hyperlink)
If Target.TextToDisplay = "Clear Cell" Then
ClearThatCell
End If
End Sub
Note there's also a Workbook-level event: use that if you'd like to be able to trap any hyperlink click in the workbook.
Private Sub Workbook_SheetFollowHyperlink(ByVal Sh As Object, _
ByVal Target As Hyperlink)
End Sub
Called code:
Sub ClearThatCell()
ThisWorkbook.Sheets("Sheet2").Range("A1").ClearContents
End Sub
' Public m_data_wks As Worksheet
Sub init_links
Dim v_r As Range, n_rows as Integer
Set v_r = m_data_wks.Cells(1, 1)
n_rows = 3 'is an example of filling up cells with hyperlinks
For I = 1 To n_rows
v_r.Value = I
'The key: adding hyperlink to the v_r cell with a special subaddress for alternative usage.
'The hyperlink looks like the ordinary but points to itself.
m_data_wks.Hyperlinks.Add Anchor:=v_r, Address:="", SubAddress:=v_r.Address(External:=False, RowAbsolute:=False, columnAbsolute:=False)
Set v_r = v_r.Offset(1)
Next I
end sub
'Private WithEvents App As Application
Private Sub App_SheetFollowHyperlink(ByVal Sh As Object, ByVal Target As Hyperlink)
Dim v_dst As Worksheet, v_index_s As String, v_index_i As Integer
'get_context sets v_dst the proper worksheet
'get_context Sh.Parent, v_dst
If v_dst Is Nothing Then Exit Sub
On Error GoTo Ext
'Using the value of the cell for choosing which to delete
v_index_s = CStr(Sh.Range(Target.SubAddress).Value)
If v_index_s = "#" Then
v_index_i = 0
Else
v_index_i = CLng(v_index_s)
End If
'Here the v_index_i points to the row instead of a cell for deleting
v_dst.Rows(v_index_i).Delete
Exit Sub
Ext:
If Err.Number <> 0 Then
MsgBox "Error occured while deleting by hyperlink: " & Err.Number & ", " & Err.Description, vbExclamation, "Non critical error"
Err.Clear
End If
End Sub