I use this code to prevent entries of text that are not valid email addresses. The user has a UserForm with 22 textboxes for a user to input the addresses into a range of cells. How can I get the message box to show where the error was? Or, should I put this "check" in a different place, like in the "CommandButton1_Click()" sub?
This code is in the "Private Sub Worksheet_Change(ByVal Target As Range)" sheet.
If Target.Cells.CountLarge = 1 Then
If Target.Column = 13 And Target.Value <> "" And Evaluate("COUNTIF(" & Target.Address & ",""*#*.*"")") <> 1 Then
Target.ClearContents
Target.Activate
MsgBox "Please enter a valid email address."
End If
End If
If Target.Cells.CountLarge = 1 Then
If Target.Column = 13 And Target.Value <> "" And Evaluate("COUNTIF(" & Target.Address & ",""*#*.*"")") <> 1 Then
MsgBox "Email address ''" & Target.Value & "'' in " & Target.Address & " is not a valid email address." & _
vbNewLine & "Please enter a valid email address."
Target.ClearContents
Target.Activate
End If
End If
Related
I have tried a lot of stuff but I can't find a fix to it I made it so that a check box if checked, it makes true and false statements in cell Q46 and function =IF(Q46=TRUE,DAY(TODAY()),0 in cell Q47 and in VBA I used this code I know it has a lot of validation that i won't use but I found it online and it works perfectly fine
Private Sub Worksheet_Change(ByVal Target As Range)
'Specify the target cell whose entry shall be the sheet tab name.
If Target.Address <> "$Q$47" Then Exit Sub
'If the target cell is empty (contents cleared) then don't change the sheet name
If IsEmpty(Target) Then Exit Sub
'If the length of the target cell's entry is greater than 31 characters, disallow the entry.
If Len(Target.Value) > 31 Then
MsgBox "Worksheet tab names cannot be greater than 31 characters in length." & vbCrLf & _
"You entered " & Target.Value & ", which has " & Len(Target.Value) & " characters.", , "Keep it under 31 characters"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
'Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :.
'Verify that none of these characters are present in the cell's entry.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(Target.Value, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates sheet naming rules." & vbCrLf & vbCrLf & _
"Please re-enter a sheet name without the ''" & IllegalCharacter(i) & "'' character.", 48, "Not a possible sheet name !!"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
Next i
'Verify that the proposed sheet name does not already exist in the workbook.
Dim strSheetName As String, wks As Worksheet, bln As Boolean
strSheetName = Trim(Target.Value)
On Error Resume Next
Set wks = ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
'If the worksheet name does not already exist, name the active sheet as the target cell value.
'Otherwise, advise the user that duplicate sheet names are not allowed.
If bln = False Then
ActiveSheet.Name = strSheetName
Else
MsgBox "There is already a sheet named " & strSheetName & "." & vbCrLf & _
"Please enter a unique name for this sheet."
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
End If
End Sub
but the problem is the cell I use which is Q47 must be active, its like I must write in it the value for it to rename not check a box so is there a way I can make it so that when I check the box and it becomes "TRUE" in cell Q46 and write day in Q47 it automatically change the sheet name to Q47?
The checkbox with a linked cell will not trigger the worksheet_change event. Do assign a macro to the checkbox (right click ->view code).
As you said it there is a lot in that code that you don't need but as you want to keep it as did not take it out
Private Sub CheckBox1_Click()
Dim Target As Range
Set Target = ActiveSheet.Range("q47")
'Specify the target cell whose entry shall be the sheet tab name.
If Target.Address <> "$Q$47" Then
Exit Sub
End If
'If the target cell is empty (contents cleared) then don't change the sheet name
If IsEmpty(Target) Then Exit Sub
'If the length of the target cell's entry is greater than 31 characters, disallow the entry.
If Len(Target.Value) > 31 Then
MsgBox "Worksheet tab names cannot be greater than 31 characters in length." & vbCrLf & _
"You entered " & Target.Value & ", which has " & Len(Target.Value) & " characters.", , "Keep it under 31 characters"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
'Sheet tab names cannot contain the characters /, \, [, ], *, ?, or :.
'Verify that none of these characters are present in the cell's entry.
Dim IllegalCharacter(1 To 7) As String, i As Integer
IllegalCharacter(1) = "/"
IllegalCharacter(2) = "\"
IllegalCharacter(3) = "["
IllegalCharacter(4) = "]"
IllegalCharacter(5) = "*"
IllegalCharacter(6) = "?"
IllegalCharacter(7) = ":"
For i = 1 To 7
If InStr(Target.Value, (IllegalCharacter(i))) > 0 Then
MsgBox "You used a character that violates sheet naming rules." & vbCrLf & vbCrLf & _
"Please re-enter a sheet name without the ''" & IllegalCharacter(i) & "'' character.", 48, "Not a possible sheet name !!"
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
Exit Sub
End If
Next i
'Verify that the proposed sheet name does not already exist in the workbook.
Dim strSheetName As String, wks As Worksheet, bln As Boolean
strSheetName = Trim(Target.Value)
On Error Resume Next
Set wks = ActiveWorkbook.Worksheets(strSheetName)
On Error Resume Next
If Not wks Is Nothing Then
bln = True
Else
bln = False
Err.Clear
End If
'If the worksheet name does not already exist, name the active sheet as the target cell value.
'Otherwise, advise the user that duplicate sheet names are not allowed.
If bln = False Then
ActiveSheet.Name = strSheetName
Else
MsgBox "There is already a sheet named " & strSheetName & "." & vbCrLf & _
"Please enter a unique name for this sheet."
Application.EnableEvents = False
Target.ClearContents
Application.EnableEvents = True
End If
End Sub
So my code starts on a different sheet with a button click. The code below stops the user from continuing with an error message if the user does not put in a value in cell "B38" on the "Pricing checklist" sheet. Is there a way to bring the user to the cell so they can input a value?
If ThisWorkbook.Sheets("Pricing checklist").Range("B38").Value = "" Then
MsgBox "Please enter the Sales Rep. " _
& vbCrLf & vbCrLf & "Press OK to exit and try again.", vbCritical
Exit Sub
End If
Select a Cell Using Application.Goto
Application.Goto method
Sub CheckPrice()
Dim PriceCell As Range
Set PriceCell = ThisWorkbook.Worksheets("Pricing checklist").Range("B38")
If Len(CStr(PriceCell.Value)) = 0 Then
MsgBox "Please enter the Sales Rep. " _
& vbCrLf & vbCrLf & "Press OK to exit and try again.", vbCritical
Application.Goto PriceCell, True ' to not scroll, remove 'True'
Exit Sub
End If
End Sub
I have an excel table with a column named "Completed?" that users select Yes or No from the drop down. If they Select Yes a Message Box using vbOKCancel pops up. If they confirm Yes that part is working so far, but if anything else happens (they hit Cancel, or X out, etc) I want this field to be changed to "No" - this is what I'm struggling with.
It seems like it should be simple - any ideas?
If Target.Column = 3 And Target.Value = "Yes" Then
Dim answer As Integer
answer = MsgBox("Are you sure you want to mark this as Completed? This will move the record to the Completed Tab and cannot be undone.", vbOKCancel + vbCritical, "CRITICAL WARNING")
If answer = vbOK Then MsgBox ("OK")
'need help with this next row
Else: Target.Value = "No"
End If
End Sub
Fundimentaily, you issue is missuse of the If Then Else End IF structure. (you are mixing Multi Line and Single Line syntax)
See here for more details
There are some other issues too, see inline comments
Private Sub Worksheet_Change(ByVal Target As Range)
Dim answer As VbMsgBoxResult ' use correct data type
Dim rng As Range, cl As Range
On Error GoTo EH ' ensure events get turned back on
Application.EnableEvents = False ' prevent event cascade
Set rng = Application.Intersect(Target, Me.Columns(3)) ' get all cells in column 3 that changed
For Each cl In rng ' process each changed cell
If LCase(cl.Value) = "yes" Or LCase(cl.Value) = "y" Then ' case insensitive
answer = MsgBox("Are you sure you want to mark row " & cl.Row & " as Completed?" & vbNewLine & vbNewLine & "This will move the record to the Completed Tab and cannot be undone.", vbOKCancel + vbCritical, "CRITICAL WARNING")
If answer = vbOK Then
cl.Value = "Yes" ' Standardise case
' MsgBox "OK" ' this is a bit annoying
Else
cl.Value = "No"
End If
End If
Next
EH:
Application.EnableEvents = True
End Sub
try this:
If Target.Column = 3 And Target.Value = "Yes" Then
Dim answer As Integer
answer = MsgBox("Are you sure you want to mark this as Completed? " & _
"This will move the record to the Completed Tab and cannot be undone.", vbOKCancel + vbCritical, "CRITICAL WARNING")
If answer = vbOK Then
MsgBox ("OK")
Else
Target.Value = "No"
End If
End If
Hi there i currently have below code whereby it will send email every time it meets target of 16, 64 and 125 however is it possible along with dates
for example only send email if value of 16 is within 3 months, 64 if it is within 6 month and 125 over one year period.
Private Sub Worksheet_Calculate()
Dim NotSentMsg As String
Dim MyMsg As String
Dim SentMsg As String
On Error GoTo errHandler:
Sheet3.Unprotect Password:="1234"
NotSentMsg = "Not Sent"
SentMsg = "Sent"
With Me.Range("B6")
If Not IsNumeric(.Value) Then
MyMsg = "Not numeric"
Else
If .Value = 16 <= Now() - 90 Or .Value = 64 <= Now() - 190 Or .Value > 125 <= Now() - 365 Then
MyMsg = SentMsg
If .Offset(0, 1).Value = NotSentMsg Then
Call Mail_Outlook_With_Signature_Html_2
MsgBox "Email has been sent", vbInformation
End If
Else
MyMsg = NotSentMsg
End If
End If
Application.EnableEvents = False
.Offset(0, 1).Value = MyMsg
Application.EnableEvents = True
End With
Application.EnableEvents = True
Sheet3.Protect Password:="1234"
On Error GoTo 0
Exit Sub
errHandler:
MsgBox "An Error has Occurred " & vbCrLf & _
"The error number is: " & Err.Number & vbCrLf & _
Err.Description & vbCrLf & "Please Contact Admin"
End Sub
Hi Please see screenshot of yearly diary
enter image description here
I am looking for a function to print in a comment box, who was the users that changed the data from that cell. What I have for now is this:
Private Sub Worksheet_Change(ByVal Target As Range)
If Range("A" & Target.Row).Value = "" Then GoTo EndeSub
If Not Intersect(Range("C:JA"), Target) Is Nothing Then
On Error GoTo EndeSub
Application.EnableEvents = False
Range("B" & Target.Row) = Now
End If
EndeSub:
Application.EnableEvents = True
End Sub
It "triggers" automatically when someone types something in a cell.
And is printing only the last user name that changed the data, but I want to be some kind of a log, to print all the users. Do you think it is possible?
One way is, insert a New Sheet and name it "Log" and place the two headers like this...
On Log Sheet
A1 --> Date/Time
B1 --> User
Now replace your existing code with this...
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Range("A" & Target.Row).Value = "" Then GoTo EndeSub
Dim wsLog As Worksheet
If Not Intersect(Range("C:JA"), Target) Is Nothing Then
On Error GoTo EndeSub
Set wsLog = Sheets("Log")
Application.EnableEvents = False
Range("B" & Target.Row) = Now
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 1) = Environ("UserName")
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1) = Now
End If
EndeSub:
Application.EnableEvents = True
End Sub
So each time any user makes changes in the target range, the time of change and the user name will be listed on Log Sheet.
Edit:
As per the new setup, these column headers should be there on the Log Sheet.
A1 --> Date/Time
B1 --> User
C1 --> Cell
D1 --> Old Value
E1 --> New Value
Then replace the existing code with the following two codes...
Dim oVal
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Range("A" & Target.Row).Value = "" Then GoTo EndeSub
Dim wsLog As Worksheet
If Not Intersect(Range("C:JA"), Target) Is Nothing Then
On Error GoTo EndeSub
Set wsLog = Sheets("Log")
Application.EnableEvents = False
Range("B" & Target.Row) = Now
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 1) = Environ("UserName")
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 2) = Target.Address(0, 0)
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 3) = oVal
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1, 4) = Target.Value
wsLog.Range("A" & Rows.Count).End(xlUp).Offset(1) = Now
End If
EndeSub:
Application.EnableEvents = True
End Sub
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge > 1 Then Exit Sub
If Not Intersect(Range("C:JA"), Target) Is Nothing Then
oVal = Target
End If
End Sub
In a Public Module
Sub LogChange(Target As Range)
Dim cell As Range, vNew As Variant, vOld As Variant
vNew = Target.value
Application.Undo
vOld = Target.value
Target.value = vNew
With getLogWorksheet
With .Range("A" & .Rows.Count).End(xlUp).Offset(1)
' Array("Date/Time", "UserName", "Worksheet", "Address", "Old Value", "New Value")
.Resize(1, 6).value = Array(Now, Environ("UserName"), Target.Parent.Name, Target.Address(False, False), vOld, vNew)
End With
End With
End Sub
Private Function getLogWorksheet() As Workbook
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets("Log")
On Error GoTo 0
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add
ws.Visible = xlSheetVeryHidden
ws.Name = "Log"
ws.Range("A1").Resize(1, 6).value = Array("Date/Time", "UserName", "Worksheet", "Address", "Old Value", "New Value")
End If
End Function
In a Worksheet Module
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.CountLarge > 1 Then
Application.Undo
MsgBox "Changing more than 1 cell at a time is prohibited", vbCritical, "Action Undone"
ElseIf Not Intersect(Range("C:JA"), Target) Is Nothing Then
LogChange Target
End If
End Sub
Another bit of code to give you some ideas:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
val_before = Target.Value
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Count > 1 Then
MsgBox Target.Count & " cells were changed!"
Exit Sub
End If
If Target.Comment Is Nothing Then
Target.AddComment
existingcomment = ""
Else
existingcomment = Target.Comment.Text & vbLf & vbLf
End If
Target.Comment.Text Text:=Format(Now(), "yyyy-mm-dd") & ":" & vbLf & Environ$("Username") & _
" changed " & Target.Address & " from:" & vbLf & """" & val_before & _
"""" & vbLf & "to:" & vblkf & """" & Target.Value & """"
End Sub
Any time a cell is selected, it stores the cell's existing value in a variable. If the cell is changed, it creates a new comment in the cell (or appends the existing comment if there is one) with the date, username, cell address, and the "before and after" values. This could be super annoying if someone's trying to make a lot of changes, and if there are multiple changes at once, then it will just warn you without creating a comment. I'd suggest you practice on a blank workbook (or a 2nd copy of the one you're working on) in case there are any problems. Be sure to Google any of the properties/methods than you are unfamiliar with, for the sake of learning, and for building a solution to fit your needs!